#  File src/library/tools/R/QC.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2014 The R 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 of the License, 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/

## R CMD check uses
## .find_charset
## .check_namespace
## .check_package_depends
## .check_demo_index
## .check_vignette_index
## .check_package_subdirs
## .check_citation
## .check_package_ASCII_code
## .check_package_code_syntax
## .check_packages_used
## .checkS3methods
## .checkReplaceFuns
## .checkFF
## .check_package_code_shlib
## .check_package_code_startup_functions
## .check_package_code_assign_to_globalenv
## .check_package_code_attach
## .check_package_code_data_into_globalenv
## .check_code_usage_in_package
## .check_T_and_F
## .check_dotInternal
## .check_package_parseRd
## .check_Rd_xrefs
## undoc
## codoc
## codocData
## codocClass
## checkDocFiles
## checkDocStyle
## .check_package_datasets
## .check_package_compact_datasets
## .check_package_compact_sysdata
## .check_make_vars
## .createExdotR (testing.R)
## .runPackageTestsR (testing.R)
## .get_LaTeX_errors_from_log_file
## .check_package_CRAN_incoming
## .check_Rd_contents

## R CMD build uses .check_package_subdirs

## NB: 'tools' cannot use NAMESPACE imports from utils, as it exists first

##' a "default" print method used "below" (in several *.R):
.print.via.format <- function(x, ...) {
    writeLines(format(x, ...))
    invisible(x)
}

## utility for whether Rd sources are available.
.haveRds <- function(dir)
{
    ## either source package or pre-2.10.0 installed package
    if (file_test("-d", file.path(dir, "man"))) return(TRUE)
    file.exists((file.path(dir, "help", "paths.rds")))
}

### * undoc/F/out

undoc <-
function(package, dir, lib.loc = NULL)
{
    ## Argument handling.
    ## <NOTE>
    ## Earlier versions used to give an error if there were no Rd
    ## objects.  This is not right: if there is code or data but no
    ## documentation, everything is undocumented ...
    ## </NOTE>
    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        dir <- find.package(package, lib.loc)
        ## Using package installed in @code{dir} ...
        is_base <- package == "base"

        all_doc_topics <- Rd_aliases(package, lib.loc = dirname(dir))

        ## Load package into code_env.
        if(!is_base)
            .load_package_quietly(package, lib.loc)
        code_env <- .package_env(package)

        code_objs <- ls(envir = code_env, all.names = TRUE)
        pkgname <- package
    }
    else {
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        ## Using sources from directory @code{dir} ...
        if(!file_test("-d", dir))
            stop(gettextf("directory '%s' does not exist", dir),
                 domain = NA)
        else
            dir <- file_path_as_absolute(dir)
        pkgname <- basename(dir)
        is_base <- pkgname == "base"

        all_doc_topics <- Rd_aliases(dir = dir)

        code_env <- new.env(hash = TRUE)
        code_dir <- file.path(dir, "R")
        if(file_test("-d", code_dir)) {
            dfile <- file.path(dir, "DESCRIPTION")
            meta <- if(file_test("-f", dfile))
                .read_description(dfile)
            else
                character()
            .source_assignments_in_code_dir(code_dir, code_env, meta)
            sys_data_file <- file.path(code_dir, "sysdata.rda")
            if(file_test("-f", sys_data_file))
                load(sys_data_file, code_env)
        }

        code_objs <- ls(envir = code_env, all.names = TRUE)

        ## Does the package have a NAMESPACE file?  Note that when
        ## working on the sources we (currently?) cannot deal with the
        ## (experimental) alternative way of specifying the namespace.
        if(file.exists(file.path(dir, "NAMESPACE"))) {
            nsInfo <- parseNamespaceFile(basename(dir), dirname(dir))
            ## Look only at exported objects (and not declared S3
            ## methods).
            OK <- intersect(code_objs, nsInfo$exports)
            for(p in nsInfo$exportPatterns)
                OK <- c(OK, grep(p, code_objs, value = TRUE))
            code_objs <- unique(OK)
        }
    }

    ## Find the data sets to work on.
    data_dir <- file.path(dir, "data")
    data_objs <- if(file_test("-d", data_dir))
	unlist(.try_quietly(list_data_in_pkg(dataDir = data_dir)),
	       use.names = FALSE)
    else
        character()

    ## There was a time when packages contained code or data (or both).
    ## But not anymore ...
    if(!missing(package)
       && (!length(code_objs))
       && (!length(data_objs))
       && getOption("verbose"))
        message("neither code nor data objects found")

    if(!is_base) {
        ## Code objects in add-on packages with names starting with a
        ## dot are considered 'internal' (not user-level) by
        ## convention.
        code_objs <- grep("^[^.].*", code_objs, value = TRUE)
        ## Note that this also allows us to get rid of S4 meta objects
        ## (with names starting with '.__C__' or '.__M__'; well, as long
        ## as there are none in base).

        ## Implicit generic functions exist to turn method dispatch on
        ## in this package, but their definition and documentation belongs
        ## to the package in their package slot, so eliminate any
        ## foreign generic functions from code_objs
        if(.isMethodsDispatchOn()) {
            code_objs <-
                Filter(function(f) {
                    ## NB: this get() is expensive as it loads every object
                    fdef <- get(f, envir = code_env)
                    if(methods::is(fdef, "genericFunction"))
                        fdef@package == pkgname
                    else
                        TRUE
                },
                       code_objs)
        }

        ## Allow group generics to be undocumented other than in base.
        ## In particular, those from methods partially duplicate base
        ## and are documented in base's groupGenerics.Rd.
        code_objs <- setdiff(code_objs,
                             c("Arith", "Compare", "Complex", "Logic",
                               "Math", "Math2", "Ops", "Summary"))
    }

    undoc_things <-
        list("code objects" =
             unique(setdiff(code_objs, all_doc_topics)),
             "data sets" =
             unique(setdiff(data_objs, all_doc_topics)))

    if(.isMethodsDispatchOn()) {
        ## Undocumented S4 classes?
        S4_classes <- methods::getClasses(code_env)
        ## <NOTE>
        ## There is no point in worrying about exportClasses directives
        ## in a NAMESPACE file when working on a package source dir, as
        ## we only source the assignments, and hence do not get any
        ## S4 classes or methods.
        ## </NOTE>
        ## The bad ones:
        S4_classes <-
            S4_classes[!sapply(S4_classes,
                               function(u) utils:::topicName("class", u))
                       %in% all_doc_topics]
        undoc_things <-
            c(undoc_things, list("S4 classes" = unique(S4_classes)))
    }

    if(.isMethodsDispatchOn()) {
        ## Undocumented S4 methods?
        ## <NOTE>
        ## There is no point in worrying about exportMethods directives
        ## in a NAMESPACE file when working on a package source dir, as
        ## we only source the assignments, and hence do not get any
        ## S4 classes or methods.
        ## </NOTE>
        .make_S4_method_siglist <- function(g) {
            mlist <- .get_S4_methods_list(g, code_env)
            sigs <- .make_siglist(mlist) #  s/#/,/g
            if(length(sigs))
                paste0(g, ",", sigs)
            else
                character()
        }
        S4_methods <- lapply(.get_S4_generics(code_env),
                             .make_S4_method_siglist)
        S4_methods <- as.character(unlist(S4_methods, use.names = FALSE))

        ## The bad ones:
        S4_methods <-
            S4_methods[!sapply(S4_methods,
                               function(u)
                               utils:::topicName("method", u))
                       %in% all_doc_topics]
        undoc_things <-
            c(undoc_things,
              list("S4 methods" =
                   unique(sub("([^,]*),(.*)",
                              "generic '\\1' and siglist '\\2'",
                              S4_methods))))
    }
    if(is_base) {
        ## We use .ArgsEnv and .GenericArgsEnv in checkS3methods() and
        ## codoc(), so we check here that the set of primitives has not
        ## been changed.
        base_funs <- ls("package:base", all.names=TRUE)
        prim <- sapply(base_funs,
                       function(x) is.primitive(get(x, "package:base")))
        prims <- base_funs[prim]
        prototypes <- sort(c(ls(envir=.ArgsEnv, all.names=TRUE),
                             ls(envir=.GenericArgsEnv, all.names=TRUE)))
        extras <- setdiff(prototypes, prims)
        if(length(extras))
            undoc_things <- c(undoc_things, list(prim_extra=extras))
        langElts <- c("$","$<-","&&","(",":","@","@<-","[","[[",
                      "[[<-","[<-","{","||","~","<-","<<-","=","break","for",
                      "function","if","next","repeat","return", "while")
        miss <- setdiff(prims, c(langElts, prototypes))
        if(length(miss))
            undoc_things <- c(undoc_things, list(primitives=miss))
    }

    class(undoc_things) <- "undoc"
    undoc_things
}

format.undoc <-
function(x, ...)
{
    .fmt <- function(i) {
        tag <- names(x)[i]
        msg <- switch(tag,
                      "code objects" =
                      gettext("Undocumented code objects:"),
                      "data sets" =
                      gettext("Undocumented data sets:"),
                      "S4 classes" =
                      gettext("Undocumented S4 classes:"),
                      "S4 methods" =
                      gettext("Undocumented S4 methods:"),
                      prim_extra =
                      gettext("Prototyped non-primitives:"),
                      gettextf("Undocumented %s:", tag))
        c(msg,
          ## We avoid markup for indicating S4 methods, hence need to
          ## special-case output for these ...
          if(tag == "S4 methods") {
              strwrap(x[[i]], indent = 2L, exdent = 4L)
          } else {
              .pretty_format(x[[i]])
          })
    }

    as.character(unlist(lapply(which(sapply(x, length) > 0L), .fmt)))
}

### * codoc

codoc <-
function(package, dir, lib.loc = NULL,
         use.values = NULL, verbose = getOption("verbose"))
{
    has_namespace <- FALSE

    ## Argument handling.
    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        dir <- find.package(package, lib.loc)
        ## Using package installed in @code{dir} ...
        code_dir <- file.path(dir, "R")
        if(!file_test("-d", code_dir))
            stop(gettextf("directory '%s' does not contain R code",
                          dir),
                 domain = NA)
        if(!.haveRds(dir))
            stop(gettextf("directory '%s' does not contain Rd objects", dir),
                 domain = NA)
        is_base <- basename(dir) == "base"

        ## Load package into code_env.
        if(!is_base)
            .load_package_quietly(package, lib.loc)
        code_env <- .package_env(package)

        objects_in_code <- objects(envir = code_env, all.names = TRUE)

        ## Does the package have a namespace?
        if(packageHasNamespace(package, dirname(dir))) {
            has_namespace <- TRUE
            ns_env <- asNamespace(package)
            S3Table <- get(".__S3MethodsTable__.", envir = ns_env)
            functions_in_S3Table <- ls(S3Table, all.names = TRUE)
            objects_in_ns <-
                setdiff(objects(envir = ns_env, all.names = TRUE),
                        c(".__NAMESPACE__.", ".__S3MethodsTable__."))
            objects_in_code_or_namespace <-
                unique(c(objects_in_code, objects_in_ns))
            objects_in_ns <- setdiff(objects_in_ns, objects_in_code)
        }
        else
            objects_in_code_or_namespace <- objects_in_code
        package_name <- package
    }
    else {
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        ## Using sources from directory @code{dir} ...
        if(!file_test("-d", dir))
            stop(gettextf("directory '%s' does not exist", dir),
                 domain = NA)
        else
            dir <- file_path_as_absolute(dir)
        code_dir <- file.path(dir, "R")
        if(!file_test("-d", code_dir))
            stop(gettextf("directory '%s' does not contain R code",
                          dir),
                 domain = NA)
        if(!.haveRds(dir))
            stop(gettextf("directory '%s' does not contain Rd objects", dir),
                 domain = NA)
        package_name <- basename(dir)
        is_base <- package_name == "base"

        code_env <- new.env(hash = TRUE)
        dfile <- file.path(dir, "DESCRIPTION")
        meta <- if(file_test("-f", dfile))
            .read_description(dfile)
        else
            character()
        .source_assignments_in_code_dir(code_dir, code_env, meta)
        sys_data_file <- file.path(code_dir, "sysdata.rda")
        if(file_test("-f", sys_data_file)) load(sys_data_file, code_env)

        objects_in_code <- objects(envir = code_env, all.names = TRUE)
        objects_in_code_or_namespace <- objects_in_code

        ## Does the package have a NAMESPACE file?  Note that when
        ## working on the sources we (currently?) cannot deal with the
        ## (experimental) alternative way of specifying the namespace.
        ## Also, do not attempt to find S3 methods.
        if(file.exists(file.path(dir, "NAMESPACE"))) {
            has_namespace <- TRUE
            objects_in_ns <- objects_in_code
            functions_in_S3Table <- character()
            ns_env <- code_env
            nsInfo <- parseNamespaceFile(basename(dir), dirname(dir))
            ## Look only at exported objects.
            OK <- intersect(objects_in_code, nsInfo$exports)
            for(p in nsInfo$exportPatterns)
                OK <- c(OK, grep(p, objects_in_code, value = TRUE))
            objects_in_code <- unique(OK)
        }
    }

    ## Find the data sets to work on.
    data_dir <- file.path(dir, "data")
    data_sets_in_code <- if(file_test("-d", data_dir))
        names(.try_quietly(list_data_in_pkg(dataDir = data_dir)))
    else
        character()

    ## Find the function objects to work on.
    functions_in_code <-
        Filter(function(f) {
                   ## This is expensive
                   f <- get(f, envir = code_env)
                   typeof(f) == "closure"
               },
               objects_in_code)
    ## Sourcing all R code files in the package is a problem for base,
    ## where this misses the .Primitive functions.  Hence, when checking
    ## base for objects shown in \usage but missing from the code, we
    ## get the primitive functions from the version of R we are using.
    ## Maybe one day we will have R code for the primitives as well ...
    ## As from R 2.5.0 we do for most generics.
    if(is_base) {
        objects_in_base <-
            objects(envir = baseenv(), all.names = TRUE)
        objects_in_code <-
            c(objects_in_code,
              Filter(.is_primitive_in_base, objects_in_base),
              c(".First.lib", ".Last.lib", ".Random.seed",
                ".onLoad", ".onAttach", ".onDetach", ".onUnload"))
        objects_in_code_or_namespace <- objects_in_code
        known_env <- .make_S3_primitive_generic_env(code_env, fixup=TRUE)
        extras <- ls(known_env, all.names = TRUE)
        functions_in_code <- c(functions_in_code, extras)
        code_env <- known_env
        known_env <- .make_S3_primitive_nongeneric_env(code_env)
        extras <- ls(known_env, all.names = TRUE)
        functions_in_code <- c(functions_in_code, extras)
        code_env <- known_env
    }

    ## Build a list with the formals of the functions in the code
    ## indexed by the names of the functions.
    function_args_in_code <-
        lapply(functions_in_code,
               function(f) formals(get(f, envir = code_env))) # get is expensive
    names(function_args_in_code) <- functions_in_code
    if(has_namespace) {
        functions_in_ns <-
            Filter(function(f) {
                       f <- get(f, envir = ns_env) # get is expensive
                       is.function(f) && (length(formals(f)) > 0L)
                   },
                   objects_in_ns)
        function_args_in_ns <-
            lapply(functions_in_ns,
                   function(f) formals(get(f, envir = ns_env)))
        names(function_args_in_ns) <- functions_in_ns

        function_args_in_S3Table <-
            lapply(functions_in_S3Table,
                   function(f) formals(get(f, envir = S3Table)))
        names(function_args_in_S3Table) <- functions_in_S3Table

        tmp <- c(function_args_in_code, function_args_in_S3Table,
                 function_args_in_ns)
        keep <- !duplicated(names(tmp))
        function_args_in_code <- tmp[keep]
        functions_in_code <- names(function_args_in_code)
    }
    if(.isMethodsDispatchOn()) {
        ## <NOTE>
        ## There is no point in worrying about exportMethods directives
        ## in a NAMESPACE file when working on a package source dir, as
        ## we only source the assignments, and hence do not get any
        ## S4 classes or methods.
        ## </NOTE>
        ## <NOTE>
        ## In principle, we can get codoc checking for S4 methods
        ## documented explicitly using the \S4method{GENERIC}{SIGLIST}
        ## markup by adding the corresponding "pseudo functions" using
        ## the Rd markup as their name.  However note that the formals
        ## recorded in the methods db only pertain to the signature, not
        ## to the ones of the function actually registered ... hence we
        ## use methods::unRematchDefinition() which knows how to extract
        ## the formals in the method definition from the
        ##   function(ARGLIST) {
        ##     .local <- function(FORMALS) BODY
        ##     .local(ARGLIST)
        ##   }
        ## redefinitions obtained by methods::rematchDefinition().
        ## </NOTE>
        check_S4_methods <-
            !identical(as.logical(Sys.getenv("_R_CHECK_CODOC_S4_METHODS_")),
                       FALSE)
        if(check_S4_methods) {
            get_formals_from_method_definition <- function(m)
                formals(methods::unRematchDefinition(m))
            lapply(.get_S4_generics(code_env),
                   function(f) {
                       mlist <- .get_S4_methods_list(f, code_env)
                       sigs <- .make_siglist(mlist)
                       if(!length(sigs)) return()
                       nm <- sprintf("\\S4method{%s}{%s}", f, sigs)
                       args <- lapply(mlist,
                                      get_formals_from_method_definition)
                       names(args) <- nm
                       functions_in_code <<-
                           c(functions_in_code, nm)
                       function_args_in_code <<-
                           c(function_args_in_code, args)
                   })
        }
    }

    check_codoc <- function(fName, ffd) {
        ## Compare the formals of the function in the code named 'fName'
        ## and formals 'ffd' obtained from the documentation.
        ffc <- function_args_in_code[[fName]]
        if(identical(use.values, FALSE)) {
            ffc <- names(ffc)
            ffd <- names(ffd)
            ok <- identical(ffc, ffd)
        } else {
            if(!identical(names(ffc), names(ffd)))
                ok <- FALSE
            else {
                vffc <- as.character(ffc) # values
                vffd <- as.character(ffd) # values
                if(!identical(use.values, TRUE)) {
                    ind <- nzchar(as.character(ffd))
                    vffc <- vffc[ind]
                    vffd <- vffd[ind]
                }
                ok <- identical(vffc, vffd)
            }
        }
        if(ok)
            NULL
        else
            list(list(name = fName, code = ffc, docs = ffd))
    }

    db <- if(!missing(package))
        Rd_db(package, lib.loc = dirname(dir))
    else
        Rd_db(dir = dir)

    names(db) <- db_names <- .Rd_get_names_from_Rd_db(db)

    ## pkg-defunct.Rd is not expected to list arguments
    ind <- db_names %in% paste(package_name, "defunct", sep = "-")
    db <- db[!ind]
    db_names <- db_names[!ind]

    db_usages <- lapply(db, .Rd_get_section, "usage")
    db_usages <- lapply(db_usages, .parse_usage_as_much_as_possible)
    ind <- as.logical(sapply(db_usages,
                             function(x) !is.null(attr(x, "bad_lines"))))
    bad_lines <- lapply(db_usages[ind], attr, "bad_lines")

    bad_doc_objects <- list()
    functions_in_usages <- character()
    variables_in_usages <- character()
    data_sets_in_usages <- character()
    functions_in_usages_not_in_code <- list()
    data_sets_in_usages_not_in_code <- list()

    for(docObj in db_names) {

        exprs <- db_usages[[docObj]]
        if(!length(exprs)) next

        ## Get variable names and data set usages first, mostly for
        ## curiosity.
        ind <- ! sapply(exprs, is.call)
        if(any(ind)) {
            variables_in_usages <-
                c(variables_in_usages,
                  sapply(exprs[ind], deparse))
            exprs <- exprs[!ind]
        }
        ind <- as.logical(sapply(exprs,
                                 function(e)
                                 (length(e) == 2L)
                                 && e[[1L]] == as.symbol("data")))
        if(any(ind)) {
            data_sets <- sapply(exprs[ind],
                                function(e) as.character(e[[2L]]))
            data_sets_in_usages <- c(data_sets_in_usages, data_sets)
            data_sets <- setdiff(data_sets, data_sets_in_code)
            if(length(data_sets))
                data_sets_in_usages_not_in_code[[docObj]] <- data_sets
            exprs <- exprs[!ind]
        }
        ## Split out replacement function usages.
        ind <- as.logical(sapply(exprs,
                                 .is_call_from_replacement_function_usage))
        replace_exprs <- exprs[ind]
        exprs <- exprs[!ind]
        ## Ordinary functions.
        functions <- sapply(exprs, function(e) as.character(e[[1L]]))
        ## Catch assignments: checkDocFiles() will report these, so drop
        ## them here.
        ## And also unary/binary operators
        ind <- !(functions %in% c("<-", "=", "+", "-"))
        exprs <- exprs[ind]
        functions <- functions[ind]
        functions <- .transform_S3_method_markup(as.character(functions))
        ind <- functions %in% functions_in_code
        bad_functions <-
            mapply(functions[ind],
                   exprs[ind],
                   FUN = function(x, y)
                   check_codoc(x, as.pairlist(as.alist.call(y[-1L]))),
                   SIMPLIFY = FALSE)
        ## Replacement functions.
        if(length(replace_exprs)) {
            replace_funs <-
                paste0(sapply(replace_exprs,
                             function(e) as.character(e[[2L]][[1L]])),
                      "<-")
            replace_funs <- .transform_S3_method_markup(replace_funs)
            functions <- c(functions, replace_funs)
            ind <- (replace_funs %in% functions_in_code)
            if(any(ind)) {
                bad_replace_funs <-
                    mapply(replace_funs[ind],
                           replace_exprs[ind],
                           FUN = function(x, y)
                           check_codoc(x,
                                      as.pairlist(c(as.alist.call(y[[2L]][-1L]),
                                                    as.alist.symbol(y[[3L]])))),
                           SIMPLIFY = FALSE)
                bad_functions <-
                    c(bad_functions, bad_replace_funs)
            }
        }

        bad_functions <- do.call("c", bad_functions)
        if(length(bad_functions))
            bad_doc_objects[[docObj]] <- bad_functions

        ## Determine functions with a \usage entry in the documentation
        ## but 'missing from the code'.  If a package has a namespace, we
        ## really need to look at all objects in the namespace (hence
        ## 'objects_in_code_or_namespace'), as one can access the internal
        ## symbols via ':::' and hence package developers might want to
        ## provide function usages for some of the internal functions.
        ## <FIXME>
        ## We may still have \S4method{}{} entries in functions, which
        ## cannot have a corresponding object in the code.  Hence, we
        ## remove these function entries, but should really do better,
        ## by comparing the explicit \usage entries for S4 methods to
        ## what is actually in the code.  We most likely also should do
        ## something similar for S3 methods.
        ind <- grep(.S4_method_markup_regexp, functions)
        if(any(ind))
            functions <- functions[!ind]
        ## </FIXME>
        bad_functions <- setdiff(functions, objects_in_code_or_namespace)
        if(length(bad_functions))
            functions_in_usages_not_in_code[[docObj]] <- bad_functions

        functions_in_usages <- c(functions_in_usages, functions)
    }

    ## Determine (function) objects in the code without a \usage entry.
    ## Of course, these could still be 'documented' via \alias.
    ## </NOTE>
    ## Older versions only printed this information without returning it
    ## (in case 'verbose' was true).  We now add this as an attribute to
    ## the bad_doc_objects returned.
    ## </NOTE>
    objects_in_code_not_in_usages <-
        setdiff(objects_in_code,
                c(functions_in_usages, variables_in_usages))
    functions_in_code_not_in_usages <-
        intersect(functions_in_code, objects_in_code_not_in_usages)
    ## (Note that 'functions_in_code' does not necessarily contain all
    ## (exported) functions in the package.)

    ## Determine functions which have no usage but really should have.
    ## If there is no namespace (including base), we have no idea.
    ## If there is one, everything "exported" (in the package env)
    ## should also have a \usage, apart from
    ## * Defunct functions
    ## * S4 generics.  Note that as per R-exts,
    ##     exporting methods on a generic in the namespace will also
    ##     export the generic, and exporting a generic in the namespace
    ##     will also export its methods.
    ##   so it seems there is really no way to figure out whether an
    ##   exported S4 generic should have a \usage entry or not ...
    functions_missing_from_usages <-
        if(!has_namespace) character() else {
            functions <- functions_in_code_not_in_usages
            if(.isMethodsDispatchOn()) {
                ## Drop the functions which have S4 methods.
                functions <-
                    setdiff(functions, names(.get_S4_generics(code_env)))
            }
            ## Drop the defunct functions.
            is_defunct <- function(f) {
                f <- get(f, envir = code_env) # get is expensive
                if(!is.function(f)) return(FALSE)
                (is.call(b <- body(f))
                 && identical(as.character(b[[1L]]), ".Defunct"))
            }
            functions[!sapply(functions, is_defunct)]
        }
    objects_missing_from_usages <-
        if(!has_namespace) character() else {
            c(functions_missing_from_usages,
              setdiff(objects_in_code_not_in_usages,
                      c(functions_in_code, data_sets_in_code)))
        }

    attr(bad_doc_objects, "objects_in_code_not_in_usages") <-
        objects_in_code_not_in_usages
    attr(bad_doc_objects, "functions_in_code_not_in_usages") <-
        functions_in_code_not_in_usages
    attr(bad_doc_objects, "functions_in_usages_not_in_code") <-
        functions_in_usages_not_in_code
    attr(bad_doc_objects, "function_args_in_code") <-
        function_args_in_code
    attr(bad_doc_objects, "data_sets_in_usages_not_in_code") <-
        data_sets_in_usages_not_in_code
    attr(bad_doc_objects, "objects_missing_from_usages") <-
        objects_missing_from_usages
    attr(bad_doc_objects, "functions_missing_from_usages") <-
        functions_missing_from_usages
    attr(bad_doc_objects, "has_namespace") <- has_namespace
    attr(bad_doc_objects, "bad_lines") <- bad_lines
    class(bad_doc_objects) <- "codoc"
    bad_doc_objects
}

print.codoc <-
function(x, ...)
{
    functions_in_usages_not_in_code <-
        attr(x, "functions_in_usages_not_in_code")
    if(length(functions_in_usages_not_in_code)) {
        for(fname in names(functions_in_usages_not_in_code)) {
            writeLines(gettextf("Functions or methods with usage in documentation object '%s' but not in code:",
                                fname))
            .pretty_print(unique(functions_in_usages_not_in_code[[fname]]))
            writeLines("")
        }
    }

    data_sets_in_usages_not_in_code <-
        attr(x, "data_sets_in_usages_not_in_code")
    if(length(data_sets_in_usages_not_in_code)) {
        for(fname in names(data_sets_in_usages_not_in_code)) {
            writeLines(gettextf("Data with usage in documentation object '%s' but not in code:",
                                fname))
            .pretty_print(unique(data_sets_in_usages_not_in_code[[fname]]))
            writeLines("")
        }
    }

    ## In general, functions in the code which only have an \alias but
    ## no \usage entry are not necessarily a problem---they might be
    ## mentioned in other parts of the Rd object documenting them, or be
    ## 'internal'.  However, if a package has a namespace, then all
    ## *exported* functions should have \usage entries (apart from
    ## defunct functions and S4 generics, see the above comments for
    ## functions_missing_from_usages).  Currently, this information is
    ## returned in the codoc object but not shown.  Eventually, we might
    ## add something like
    ##     functions_missing_from_usages <-
    ##         attr(x, "functions_missing_from_usages")
    ##     if(length(functions_missing_from_usages)) {
    ##         writeLines("Exported functions without usage information:")
    ##         .pretty_print(functions_in_code_not_in_usages)
    ##         writeLines("")
    ##     }
    ## similar to the above.

    if(!length(x))
        return(invisible(x))

    has_only_names <- is.character(x[[1L]][[1L]][["code"]])

    format_args <- function(s) {
        if(!length(s))
            "function()"
        else if(has_only_names)
	    paste0("function(", paste(s, collapse = ", "), ")")
        else {
            s <- paste(deparse(s), collapse = "")
            s <- gsub(" = ([,\\)])", "\\1", s)
            s <- gsub("<unescaped bksl>", "\\", s, fixed = TRUE)
            gsub("^list", "function", s)
        }
    }

    summarize_mismatches_in_names <- function(nfc, nfd) {
        if(length(nms <- setdiff(nfc, nfd)))
            writeLines(c(gettext("  Argument names in code not in docs:"),
                         strwrap(paste(nms, collapse = " "),
                                 indent = 4L, exdent = 4L)))
        if(length(nms <- setdiff(nfd, nfc)))
            writeLines(c(gettext("  Argument names in docs not in code:"),
                         strwrap(paste(nms, collapse = " "),
                                 indent = 4L, exdent = 4L)))
        len <- min(length(nfc), length(nfd))
        if(len) {
            len <- seq_len(len)
            nfc <- nfc[len]
            nfd <- nfd[len]
            ind <- which(nfc != nfd)
            len <- length(ind)
            if(len) {
                if(len > 3L) {
                    writeLines(gettext("  Mismatches in argument names (first 3):"))
                    ind <- ind[1L:3L]
                } else {
                    writeLines(gettext("  Mismatches in argument names:"))
                }
                for(i in ind) {
                    writeLines(sprintf("    Position: %d Code: %s Docs: %s",
                                       i, nfc[i], nfd[i]))
                }
            }
        }
    }

    summarize_mismatches_in_values <- function(ffc, ffd) {
        ## Be nice, and match arguments by names first.
        nms <- intersect(names(ffc), names(ffd))
        vffc <- ffc[nms]
        vffd <- ffd[nms]
        ind <- which(as.character(vffc) != as.character(vffd))
        len <- length(ind)
        if(len) {
            if(len > 3L) {
                writeLines(gettext("  Mismatches in argument default values (first 3):"))
                ind <- ind[1L:3L]
            } else {
                writeLines(gettext("  Mismatches in argument default values:"))
            }
            for(i in ind) {
                multiline <- FALSE
                cv <- deparse(vffc[[i]])
                if(length(cv) > 1L) {
                    cv <- paste(cv, collapse = "\n      ")
                    multiline <- TRUE
                }
                dv <- deparse(vffd[[i]])
                if(length(dv) > 1L) {
                    dv <- paste(dv, collapse = "\n      ")
                    multiline <- TRUE
                }
                dv <- gsub("<unescaped bksl>", "\\", dv, fixed = TRUE)
                sep <- if(multiline) "\n    " else " "
                writeLines(sprintf("    Name: '%s'%sCode: %s%sDocs: %s",
                                   nms[i], sep, cv, sep, dv))
            }
        }
    }

    summarize_mismatches <- function(ffc, ffd) {
        if(has_only_names)
            summarize_mismatches_in_names(ffc, ffd)
        else {
            summarize_mismatches_in_names(names(ffc), names(ffd))
            summarize_mismatches_in_values(ffc, ffd)
        }
    }

    for(fname in names(x)) {
        writeLines(gettextf("Codoc mismatches from documentation object '%s':",
                            fname))
        xfname <- x[[fname]]
        for(i in seq_along(xfname)) {
            ffc <- xfname[[i]][["code"]]
            ffd <- xfname[[i]][["docs"]]
            writeLines(c(xfname[[i]][["name"]],
                         strwrap(gettextf("Code: %s", format_args(ffc)),
                                 indent = 2L, exdent = 17L),
                         strwrap(gettextf("Docs: %s", format_args(ffd)),
                                 indent = 2L, exdent = 17L)))
            summarize_mismatches(ffc, ffd)
        }
        writeLines("")
    }

    invisible(x)
}

### * codocClasses

codocClasses <-
function(package, lib.loc = NULL)
{
    ## Compare the 'structure' of S4 classes in an installed package
    ## between code and documentation.
    ## Currently, only compares the slot names.

    ## <NOTE>
    ## This is patterned after the current codoc().
    ## It would be useful to return the whole information on class slot
    ## names found in the code and matching documentation (rather than
    ## just the ones with mismatches).
    ## Currently, we only return the names of all classes checked.
    ## </NOTE>

    bad_Rd_objects <- structure(NULL, class = "codocClasses")

    ## Argument handling.
    if(length(package) != 1L)
        stop("argument 'package' must be of length 1")
    dir <- find.package(package, lib.loc)
    if(!file_test("-d", file.path(dir, "R")))
        stop(gettextf("directory '%s' does not contain R code", dir),
             domain = NA)
    if(!.haveRds(dir))
        stop(gettextf("directory '%s' does not contain Rd objects", dir),
             domain = NA)
    is_base <- basename(dir) == "base"

    ## Load package into code_env.
    if(!is_base)
        .load_package_quietly(package, lib.loc)
    code_env <- .package_env(package)

    if(!.isMethodsDispatchOn())
        return(bad_Rd_objects)

    S4_classes <- methods::getClasses(code_env)
    if(!length(S4_classes)) return(bad_Rd_objects)

    sApply <- function(X, FUN, ...) ## fast and special case - only
        unlist(lapply(X = X, FUN = FUN, ...), recursive=FALSE, use.names=FALSE)
    ## Build Rd data base.
    db <- Rd_db(package, lib.loc = dirname(dir))

    ## Need some heuristics now.  When does an Rd object document just
    ## one S4 class so that we can compare (at least) the slot names?
    ## Try the following:
    ## 1) \docType{} identical to "class";
    ## 2) either exactly one \alias{} or only one ending in "-class"
    ## 3) a non-empty user-defined section 'Slots'.

    ## As going through the db to extract sections can take some time,
    ## we do the vectorized metadata computations first, and try to
    ## subscript whenever possible.

    idx <- sApply(lapply(db, .Rd_get_doc_type), identical, "class")
    if(!any(idx)) return(bad_Rd_objects)
    db <- db[idx]
    stats <- c(n.S4classes = length(S4_classes), n.db = length(db))

    aliases <- lapply(db, .Rd_get_metadata, "alias")
    named_class <- lapply(aliases, grepl, pattern="-class$")
    nClass <- sApply(named_class, sum)
    oneAlias <- sApply(aliases, length) == 1L
    idx <- oneAlias | nClass == 1L
    if(!any(idx)) return(bad_Rd_objects)
    db <- db[idx]
    stats["n.cl"] <- length(db)

    ## keep only the foo-class alias in case there was more than one:
    multi <- idx & !oneAlias
    aliases[multi] <-
        mapply(`[`, aliases[multi], named_class[multi],
               SIMPLIFY = FALSE, USE.NAMES = FALSE)
    aliases <- unlist(aliases[idx], use.names = FALSE)

    Rd_slots <- lapply(db, .Rd_get_section, "Slots", FALSE)
    idx <- sapply(Rd_slots, length) > 0L
    if(!any(idx)) return(bad_Rd_objects)
    db <- db[idx]; aliases <- aliases[idx]; Rd_slots <- Rd_slots[idx]
    stats["n.final"] <- length(db)

    db_names <- .Rd_get_names_from_Rd_db(db)

    .get_slot_names <- function(x) {
        ## Get \describe (inside user-defined section 'Slots'):
        ## Should this allow for several \describe blocks?
        x <- .Rd_get_section(x, "describe")
        ## Get the \item tags inside \describe.
        txt <- .Rd_get_item_tags(x)
        if(!length(txt)) return(character())
        txt <- gsub("\\\\l?dots", "...", txt)
        ## And now strip enclosing '\code{...}:'
        txt <- gsub("\\\\code\\{([^}]*)\\}:?", "\\1", as.character(txt))
        txt <- unlist(strsplit(txt, ", *"))
        .strip_whitespace(txt)
    }

    .inheritedSlotNames <- function(ext) {
	supcl <- methods::.selectSuperClasses(ext)
	unique(unlist(lapply(lapply(supcl, methods::getClassDef),
			     methods::slotNames),
		      use.names=FALSE))
    }

    S4topics <- sApply(S4_classes, utils:::topicName, type="class")
    S4_checked <- S4_classes[has.a <- S4topics %in% aliases]
    idx <- match(S4topics[has.a], aliases)
    for(icl in seq_along(S4_checked)) {
        cl <- S4_checked[icl]
        cld <- methods::getClass(cl, where = code_env)
        ii <- idx[icl]
        ## Add sanity checking later ...
        scld <- methods::slotNames(cld)
        codeSlots <- if(!is.null(scld)) sort(scld) else character()
        docSlots  <- sort(.get_slot_names(Rd_slots[[ii]]))
        superSlots <- .inheritedSlotNames(cld@contains)
        if(length(superSlots)) ## allow '\dots' in docSlots
            docSlots <-
                docSlots[is.na(match(docSlots, c("...", "\\dots")))]
        ## was if(!identical(slots_in_code, slots_in_docs)) {
        if(!all(d.in.c <- docSlots %in% codeSlots) ||
           !all(c.in.d <- (setdiff(codeSlots, superSlots)) %in% docSlots) ) {
            bad_Rd_objects[[db_names[ii]]] <-
                list(name = cl,
                     code = codeSlots,
                     inherited = superSlots,
                     docs = docSlots)
        }
    }

    attr(bad_Rd_objects, "S4_classes_checked") <- S4_checked
    attr(bad_Rd_objects, "stats") <- stats
    bad_Rd_objects
} ## end{ codocClasses }

format.codocClasses <-
function(x, ...)
{
    .fmt <- function(nm) {
        wrapPart <- function(nam) {
            capWord <- function(w) sub("\\b(\\w)", "\\U\\1", w, perl = TRUE)

            if(length(O <- docObj[[nam]]))
                strwrap(sprintf("%s: %s", gettextf(capWord(nam)),
                                paste(O, collapse = " ")),
                        indent = 2L, exdent = 8L)
        }

        docObj <- x[[nm]]
        c(gettextf("S4 class codoc mismatches from documentation object '%s':",
                   nm),
          gettextf("Slots for class '%s'", docObj[["name"]]),
          wrapPart("code"),
          wrapPart("inherited"),
          wrapPart("docs"),
          "")
    }

    as.character(unlist(lapply(names(x), .fmt)))
}

### * codocData

codocData <-
function(package, lib.loc = NULL)
{
    ## Compare the 'structure' of 'data' objects (variables or data
    ## sets) in an installed package between code and documentation.
    ## Currently, only compares the variable names of data frames found.

    ## <NOTE>
    ## This is patterned after the current codoc().
    ## It would be useful to return the whole information on data frame
    ## variable names found in the code and matching documentation
    ## (rather than just the ones with mismatches).
    ## Currently, we only return the names of all data frames checked.
    ## </NOTE>

    bad_Rd_objects <- structure(NULL, class = "codocData")

    ## Argument handling.
    if(length(package) != 1L)
        stop("argument 'package' must be of length 1")

    dir <- find.package(package, lib.loc)

    ## Build Rd data base.
    db <- Rd_db(package, lib.loc = dirname(dir))

    is_base <- basename(dir) == "base"
    has_namespace <- !is_base && packageHasNamespace(package, dirname(dir))

    ## Load package into code_env.
    if(!is_base)
        .load_package_quietly(package, lib.loc)
    code_env <- .package_env(package)
    if(has_namespace) ns_env <- asNamespace(package)

    ## Could check here whether the package has any variables or data
    ## sets (and return if not).


    ## Need some heuristics now.  When does an Rd object document a
    ## data.frame (could add support for other classes later) variable
    ## or data set so that we can compare (at least) the names of the
    ## variables in the data frame?  Try the following:
    ## * just one \alias{};
    ## * if documentation was generated via prompt, there is a \format
    ##   section starting with 'A data frame with' (but many existing Rd
    ##   files instead have 'This data frame contains' and containing
    ##   one or more \describe sections inside.

    ## As going through the db to extract sections can take some time,
    ## we do the vectorized metadata computations first, and try to
    ## subscript whenever possible.
    aliases <- lapply(db, .Rd_get_metadata, "alias")
    idx <- sapply(aliases, length) == 1L
    if(!any(idx)) return(bad_Rd_objects)
    db <- db[idx]
    aliases <- aliases[idx]

    names(db) <- .Rd_get_names_from_Rd_db(db)

    .get_data_frame_var_names <- function(x) {
        ## Make sure that there is exactly one format section:
        ## using .Rd_get_section() would get the first one.
        x <- x[RdTags(x) == "\\format"]
        if(length(x) != 1L) return(character())
        ## Drop comments.
        ## <FIXME>
        ## Remove calling .Rd_drop_comments() eventually.
        x <- .Rd_drop_comments(x[[1L]])
        ## </FIXME>
        ## What did the format section start with?
        if(!grepl("^[ \n\t]*(A|This) data frame",
                  .Rd_deparse(x, tag = FALSE)))
            return(character())
        ## Get \describe inside \format.
        ## Should this allow for several \describe blocks?
        x <- .Rd_get_section(x, "describe")
        ## Get the \item tags inside \describe.
        txt <- .Rd_get_item_tags(x)
        if(!length(txt)) return(character())
        txt <- gsub("(.*):$", "\\1", as.character(txt))
        txt <- gsub("\\\\code\\{(.*)\\}:?", "\\1", txt)
        ## Argh.  Of course, variable names can have a '_', which needs
        ## to be escaped if not in \code{}, and the prompt() default is
        ## not to put variable names inside \code{}.
        txt <- gsub("\\\\_", "_", txt)
        txt <- unlist(strsplit(txt, ", *"))
        .strip_whitespace(txt)
    }

    Rd_var_names <- lapply(db, .get_data_frame_var_names)

    idx <- (sapply(Rd_var_names, length) > 0L)
    if(!length(idx)) return(bad_Rd_objects)
    aliases <- unlist(aliases[idx])
    Rd_var_names <- Rd_var_names[idx]

    db_names <- names(db)[idx]

    data_env <- new.env(hash = TRUE)
    data_dir <- file.path(dir, "data")
    ## with lazy data we have data() but don't need to use it.
    has_data <- file_test("-d", data_dir) &&
        !file_test("-f", file.path(data_dir, "Rdata.rdb"))
    data_exts <- .make_file_exts("data")

    ## Now go through the aliases.
    data_frames_checked <- character()
    for(i in seq_along(aliases)) {
        ## Store the documented variable names.
        var_names_in_docs <- sort(Rd_var_names[[i]])
        ## Try finding the variable or data set given by the alias.
        al <- aliases[i]
        if(exists(al, envir = code_env, mode = "list",
                  inherits = FALSE)) {
            al <- get(al, envir = code_env, mode = "list")
        } else if(has_namespace && exists(al, envir = ns_env, mode = "list",
                  inherits = FALSE)) {
            al <- get(al, envir = ns_env, mode = "list")
        } else if(has_data) {
            ## Should be a data set.
            if(!length(dir(data_dir)
                       %in% paste(al, data_exts, sep = "."))) {
                next                    # What the hell did we pick up?
            }
            ## Try loading the data set into data_env.
            utils::data(list = al, envir = data_env)
            if(exists(al, envir = data_env, mode = "list",
                      inherits = FALSE)) {
                al <- get(al, envir = data_env, mode = "list")
            }
            ## And clean up data_env.
            rm(list = ls(envir = data_env, all.names = TRUE),
               envir = data_env)
        }
        if(!is.data.frame(al)) next
        ## Now we should be ready:
        data_frames_checked <- c(data_frames_checked, aliases[i])
        var_names_in_code <- sort(names(al))
        if(!identical(var_names_in_code, var_names_in_docs))
            bad_Rd_objects[[db_names[i]]] <-
                list(name = aliases[i],
                     code = var_names_in_code,
                     docs = var_names_in_docs)
    }

    attr(bad_Rd_objects, "data_frames_checked") <-
        as.character(data_frames_checked)
    bad_Rd_objects
}

format.codocData <-
function(x, ...)
{
    format_args <- function(s) paste(s, collapse = " ")

    .fmt <- function(nm) {
        docObj <- x[[nm]]
        ## FIXME singular or plural?
        c(gettextf("Data codoc mismatches from documentation object '%s':", nm),
          gettextf("Variables in data frame '%s'", docObj[["name"]]),
          strwrap(gettextf("Code: %s", format_args(docObj[["code"]])),
                  indent = 2L, exdent = 8L),
          strwrap(gettextf("Docs: %s", format_args(docObj[["docs"]])),
                  indent = 2L, exdent = 8L),
          "")
    }

    as.character(unlist(lapply(names(x), .fmt)))
}

### * checkDocFiles

checkDocFiles <-
function(package, dir, lib.loc = NULL)
{
    ## Argument handling.
    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        dir <- find.package(package, lib.loc)
        ## Using package installed in @code{dir} ...
    }
    else {
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        ## Using sources from directory @code{dir} ...
        if(!file_test("-d", dir))
            stop(gettextf("directory '%s' does not exist", dir),
                 domain = NA)
        else
            dir <- file_path_as_absolute(dir)
    }

    db <- if(!missing(package))
        Rd_db(package, lib.loc = dirname(dir))
    else
        Rd_db(dir = dir)

    db_aliases <- lapply(db, .Rd_get_metadata, "alias")
    db_keywords <- lapply(db, .Rd_get_metadata, "keyword")

    db_names <- .Rd_get_names_from_Rd_db(db)
    names(db) <- names(db_aliases) <- db_names

    db_usages <- lapply(db, .Rd_get_section, "usage")
    ## We traditionally also use the usage "texts" for some sanity
    ## checking ...
    ## <FIXME>
    ## Remove calling .Rd_drop_comments() eventually.
    db_usage_texts <-
        lapply(db_usages,
               function(e) .Rd_deparse(.Rd_drop_comments(e)))
    ## </FIXME>
    db_usages <- lapply(db_usages, .parse_usage_as_much_as_possible)
    ind <- as.logical(sapply(db_usages,
                             function(x) !is.null(attr(x, "bad_lines"))))
    bad_lines <- lapply(db_usages[ind], attr, "bad_lines")

    ## Exclude internal objects from further computations.
    ind <- sapply(db_keywords,
                  function(x) length(grep("^ *internal *$", x)) > 0L )
    if(any(ind)) {                      # exclude them
        db <- db[!ind]
        db_names <- db_names[!ind]
        db_aliases <- db_aliases[!ind]
    }

    db_argument_names <- lapply(db, .Rd_get_argument_names)

    bad_doc_objects <- list()

    for(docObj in db_names) {

        exprs <- db_usages[[docObj]]
        if(!length(exprs)) next

        aliases <- db_aliases[[docObj]]
        arg_names_in_arg_list <- db_argument_names[[docObj]]

        ## Determine function names ('functions') and corresponding
        ## arguments ('arg_names_in_usage') in the \usage.  Note how we
        ## try to deal with data set documentation.
        ind <- as.logical(sapply(exprs,
                                 function(e)
                                 ((length(e) > 1L) &&
                                  !((length(e) == 2L)
                                    && e[[1L]] == as.symbol("data")))))
        exprs <- exprs[ind]
        ## Split out replacement function usages.
        ind <- as.logical(sapply(exprs,
                                 .is_call_from_replacement_function_usage))
        replace_exprs <- exprs[ind]
        exprs <- exprs[!ind]
        ## Ordinary functions.
        functions <- as.character(sapply(exprs,
                                         function(e)
                                         as.character(e[[1L]])))
        ## Catch assignments.
        ind <- functions %in% c("<-", "=")
        assignments <- exprs[ind]
        if(any(ind)) {
            exprs <- exprs[!ind]
            functions <- functions[!ind]
        }
        ## (Note that as.character(sapply(exprs, "[[", 1L)) does not do
        ## what we want due to backquotifying.)
        arg_names_in_usage <-
            unlist(sapply(exprs,
                          function(e) .arg_names_from_call(e[-1L])))
        ## Replacement functions.
        if(length(replace_exprs)) {
            replace_funs <-
                paste0(sapply(replace_exprs,
                             function(e) as.character(e[[2L]][[1L]])),
                      "<-")
            functions <- c(functions, replace_funs)
            arg_names_in_usage <-
                c(arg_names_in_usage,
                  unlist(sapply(replace_exprs,
                                function(e)
                                c(.arg_names_from_call(e[[2L]][-1L]),
                                  .arg_names_from_call(e[[3L]])))))
        }
        ## And finally transform the S3 \method{}{} markup into the
        ## usual function names ...
        ## <NOTE>
        ## If we were really picky, we would worry about possible
        ## namespace renaming.
        functions <- .transform_S3_method_markup(functions)
        ## </NOTE>
        ## Also transform the markup for S4 replacement methods.
        functions <- .transform_S4_method_markup(functions)

        ## Now analyze what we found.
        arg_names_in_usage_missing_in_arg_list <-
            setdiff(arg_names_in_usage, arg_names_in_arg_list)
        arg_names_in_arg_list_missing_in_usage <-
            setdiff(arg_names_in_arg_list, arg_names_in_usage)
        if(length(arg_names_in_arg_list_missing_in_usage)) {
            usage_text <- db_usage_texts[[docObj]]
            bad_args <- character()
            ## In the case of 'over-documented' arguments, try to be
            ## defensive and reduce to arguments which either are not
            ## syntactically valid names or do not match the \usage text
            ## (modulo word boundaries).
            bad <- !grepl("^[[:alnum:]._]+$",
                          arg_names_in_arg_list_missing_in_usage)
            if(any(bad)) {
                bad_args <- arg_names_in_arg_list_missing_in_usage[bad]
                arg_names_in_arg_list_missing_in_usage <-
                    arg_names_in_arg_list_missing_in_usage[!bad]
            }
            bad <- sapply(arg_names_in_arg_list_missing_in_usage,
                          function(x)
			  !grepl(paste0("\\b", x, "\\b"),
                                 usage_text))
            arg_names_in_arg_list_missing_in_usage <-
                c(bad_args,
                  arg_names_in_arg_list_missing_in_usage[as.logical(bad)])
            ## Note that the fact that we can parse the raw \usage does
            ## not imply that over-documented arguments are a problem:
            ## this works for Rd files documenting e.g. shell utilities
            ## but fails for files with special syntax (Extract.Rd).
        }

        ## Also test whether the objects we found from the \usage all
        ## have aliases, provided that there is no alias which ends in
        ## '-deprecated' (see e.g. base-deprecated.Rd).
        if(!length(grep("-deprecated$", aliases))) {
            functions <-
                setdiff(functions,
                        .functions_with_no_useful_S3_method_markup())
            ## Argh.  There are good reasons for keeping \S4method{}{}
            ## as is, but of course this is not what the aliases use ...
            ## <FIXME>
            ## Should maybe use utils:::topicName(), but in any case, we
            ## should have functions for converting between the two
            ## forms, see also the code for undoc().
            aliases <- sub("([^,]+),(.+)-method$",
                           "\\\\S4method{\\1}{\\2}",
                           aliases)
            ## </FIXME>
            aliases <- gsub("\\\\%", "%", aliases)
            functions_not_in_aliases <- setdiff(functions, aliases)
        }
        else
            functions_not_in_aliases <- character()

        if((length(arg_names_in_usage_missing_in_arg_list))
           || anyDuplicated(arg_names_in_arg_list)
           || (length(arg_names_in_arg_list_missing_in_usage))
           || (length(functions_not_in_aliases))
           || (length(assignments)))
            bad_doc_objects[[docObj]] <-
                list(missing = arg_names_in_usage_missing_in_arg_list,
                     duplicated =
                     arg_names_in_arg_list[duplicated(arg_names_in_arg_list)],
                     overdoc = arg_names_in_arg_list_missing_in_usage,
                     unaliased = functions_not_in_aliases,
                     assignments = assignments)

    }

    class(bad_doc_objects) <- "checkDocFiles"
    attr(bad_doc_objects, "bad_lines") <- bad_lines
    bad_doc_objects
}

format.checkDocFiles <-
function(x, ...)
{
    .fmt <- function(nm) {
        c(character(),
          if(length(arg_names_in_usage_missing_in_arg_list <-
                    x[[nm]][["missing"]])) {
              c(gettextf("Undocumented arguments in documentation object '%s'",
                         nm),
                .pretty_format(unique(arg_names_in_usage_missing_in_arg_list)))
          },
          if(length(duplicated_args_in_arg_list <-
                    x[[nm]][["duplicated"]])) {
              c(gettextf("Duplicated \\argument entries in documentation object '%s':",
                         nm),
                .pretty_format(duplicated_args_in_arg_list))
          },
          if(length(arg_names_in_arg_list_missing_in_usage <-
                    x[[nm]][["overdoc"]])) {
              c(gettextf("Documented arguments not in \\usage in documentation object '%s':",
                         nm),
                .pretty_format(unique(arg_names_in_arg_list_missing_in_usage)))
          },
          if(length(functions_not_in_aliases <-
                    x[[nm]][["unaliased"]])) {
              c(gettextf("Objects in \\usage without \\alias in documentation object '%s':",
                         nm),
                .pretty_format(unique(functions_not_in_aliases)))
          },
          if(length(assignments <-
                    x[[nm]][["assignments"]])) {
              c(gettextf("Assignments in \\usage in documentation object '%s':",
                         nm),
                sprintf("  %s", unlist(lapply(assignments, format))))
          },
          "")
    }

    y <- as.character(unlist(lapply(names(x), .fmt)))

    if(!identical(as.logical(Sys.getenv("_R_CHECK_WARN_BAD_USAGE_LINES_")),
                  FALSE)
       && length(bad_lines <- attr(x, "bad_lines"))) {
        y <- c(y,
               unlist(lapply(names(bad_lines),
                             function(nm) {
                                 c(gettextf("Bad \\usage lines found in documentation object '%s':",
                                            nm),
                                   paste(" ", bad_lines[[nm]]))
                             })),
               "")
    }

    y
}

### * checkDocStyle

checkDocStyle <-
function(package, dir, lib.loc = NULL)
{
    has_namespace <- auto_namespace <- FALSE

    ## Argument handling.
    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        dir <- find.package(package, lib.loc)
        ## Using package installed in 'dir' ...
        dfile <- file.path(dir, "DESCRIPTION")
        meta <- if(file_test("-f", dfile))
            .read_description(dfile)
        else
            character()
        code_dir <- file.path(dir, "R")
        if(!file_test("-d", code_dir))
            stop(gettextf("directory '%s' does not contain R code",
                          dir),
                 domain = NA)
        if(!.haveRds(dir))
            stop(gettextf("directory '%s' does not contain Rd objects", dir),
                 domain = NA)
        package_name <- package
        is_base <- package_name == "base"

        ## Load package into code_env.
        if(!is_base)
            .load_package_quietly(package, lib.loc)
        code_env <- .package_env(package)

        objects_in_code <- objects(envir = code_env, all.names = TRUE)

        ## Does the package have a namespace?
        ## These days all packages have namespaces, but some are
        ## auto-generated.
        if(packageHasNamespace(package, dirname(dir))) {
            has_namespace <- TRUE
            ns <- readLines(file.path(dir, "NAMESPACE"), warn = FALSE)
            auto_namespace <-
                grepl("# Default NAMESPACE created by R", ns[1L],
                      useBytes = TRUE)
            ## Determine names of declared S3 methods and associated S3
            ## generics.
            ns_S3_methods_db <- getNamespaceInfo(package, "S3methods")
            ns_S3_generics <- ns_S3_methods_db[, 1L]
            ns_S3_methods <- ns_S3_methods_db[, 3L]
        }
    }
    else {
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        ## Using sources from directory @code{dir} ...
        if(!file_test("-d", dir))
            stop(gettextf("directory '%s' does not exist", dir),
                 domain = NA)
        else
            dir <- file_path_as_absolute(dir)
        code_dir <- file.path(dir, "R")
        if(!file_test("-d", code_dir))
            stop(gettextf("directory '%s' does not contain R code",
                          dir),
                 domain = NA)
        if(!.haveRds(dir))
            stop(gettextf("directory '%s' does not contain Rd objects", dir),
                 domain = NA)
        package_name <- basename(dir)
        is_base <- package_name == "base"

        code_env <- new.env(hash = TRUE)
        dfile <- file.path(dir, "DESCRIPTION")
        meta <- if(file_test("-f", dfile))
            .read_description(dfile)
        else
            character()
        .source_assignments_in_code_dir(code_dir, code_env, meta)
        sys_data_file <- file.path(code_dir, "sysdata.rda")
        if(file_test("-f", sys_data_file)) load(sys_data_file, code_env)

        objects_in_code <- objects(envir = code_env, all.names = TRUE)

        ## Do the package sources have a NAMESPACE file?
        if(file.exists(file.path(dir, "NAMESPACE"))) {
            has_namespace <- TRUE
            nsInfo <- parseNamespaceFile(basename(dir), dirname(dir))
            ## Determine exported objects.
            OK <- intersect(objects_in_code, nsInfo$exports)
            for(p in nsInfo$exportPatterns)
                OK <- c(OK, grep(p, objects_in_code, value = TRUE))
            objects_in_code <- unique(OK)
            ## Determine names of declared S3 methods and associated S3
            ## generics.
            ns_S3_methods_db <- .get_namespace_S3_methods_db(nsInfo)
            ns_S3_generics <- ns_S3_methods_db[, 1L]
            ns_S3_methods <- ns_S3_methods_db[, 3L]
        }

    }

    ## Find the function objects in the given package.
    functions_in_code <-
        Filter(function(f) is.function(get(f, envir = code_env)),  # get is expensive
               objects_in_code)

    ## Find all S3 generics "as seen from the package".
    all_S3_generics <-
        unique(c(Filter(function(f) .is_S3_generic(f, envir = code_env),
                        functions_in_code),
                 .get_S3_generics_as_seen_from_package(dir,
                                                       !missing(package),
                                                       TRUE),
                 .get_S3_group_generics()))
    ## <FIXME>
    ## Not yet:
    code_env <- .make_S3_group_generic_env(parent = code_env)
    ## </FIXME>

    ## Find all methods in the given package for the generic functions
    ## determined above.  Store as a list indexed by the names of the
    ## generic functions.
    ## Change in 3.0.0: we only look for methods named generic.class,
    ## not those registered by a 3-arg S3method().
    methods_stop_list <- .make_S3_methods_stop_list(basename(dir))
    methods_in_package <- sapply(all_S3_generics, function(g) {
        ## This isn't really right: it assumes the generics are visible.
        if(!exists(g, envir = code_env)) return(character())
        ## <FIXME>
        ## We should really determine the name g dispatches for, see
        ## a current version of methods() [2003-07-07].  (Care is needed
        ## for internal generics and group generics.)
        ## Matching via grep() is tricky with e.g. a '$' in the name of
        ## the generic function ... hence substr().
        name <- paste0(g, ".")
        methods <-
            functions_in_code[substr(functions_in_code, 1L,
                                     nchar(name, type = "c")) == name]
        ## </FIXME>
        methods <- setdiff(methods, methods_stop_list)
        if(has_namespace) {
            ## Find registered methods for generic g.
            methods2 <- ns_S3_methods[ns_S3_generics == g]
            ## but for these purposes check name.
            OK <- substr(methods2, 1L, nchar(name, type = "c")) == name
            methods <- c(methods, methods2[OK])
        }
        methods
    })
    all_methods_in_package <- unlist(methods_in_package)
    ## There are situations where S3 methods might be documented as
    ## functions (i.e., with their full name), if they do something
    ## useful also for arguments not inheriting from the class they
    ## provide a method for.
    ## But they they should be exported under another name, and
    ## registered as an S3 method.
    ## Prior to 2.14.0 we used to allow this in the case the
    ## package has a namespace and the method is exported (even though
    ## we strongly prefer using FOO(as.BAR(x)) to FOO.BAR(x) for such
    ## cases).
    ## But this caused discontinuities with adding namespaces.
    ## Historical exception
    if(package_name == "cluster")
        all_methods_in_package <-
    	    setdiff(all_methods_in_package, functions_in_code)

    db <- if(!missing(package))
        Rd_db(package, lib.loc = dirname(dir))
    else
        Rd_db(dir = dir)

    names(db) <- db_names <- .Rd_get_names_from_Rd_db(db)

    ## Ignore pkg-deprecated.Rd and pkg-defunct.Rd.
    ind <- db_names %in% paste(package_name, c("deprecated", "defunct"),
                               sep = "-")
    db <- db[!ind]
    db_names <- db_names[!ind]

    db_usages <-
        lapply(db,
               function(Rd) {
                   Rd <- .Rd_get_section(Rd, "usage")
                   .parse_usage_as_much_as_possible(Rd)
               })
    ind <- as.logical(sapply(db_usages,
                             function(x) !is.null(attr(x, "bad_lines"))))
    bad_lines <- lapply(db_usages[ind], attr, "bad_lines")

    bad_doc_objects <- list()

    for(docObj in db_names) {

        ## Determine function names in the \usage.
        exprs <- db_usages[[docObj]]
        exprs <- exprs[sapply(exprs, length) > 1L]
        ## Ordinary functions.
        functions <-
            as.character(sapply(exprs,
                                function(e) as.character(e[[1L]])))
        ## (Note that as.character(sapply(exprs, "[[", 1L)) does not do
        ## what we want due to backquotifying.)
        ## Replacement functions.
        ind <- as.logical(sapply(exprs,
                                 .is_call_from_replacement_function_usage))
        if(any(ind)) {
            replace_funs <-
                paste0(sapply(exprs[ind],
                              function(e) as.character(e[[2L]][[1L]])),
                       "<-")
            functions <- c(functions, replace_funs)
        }

        methods_with_full_name <-
            intersect(functions, all_methods_in_package)

        functions <- .transform_S3_method_markup(functions)

        methods_with_generic <-
            sapply(intersect(functions, all_S3_generics),
                   function(g)
                   intersect(functions, methods_in_package[[g]]),
                   simplify = FALSE)

        if((length(methods_with_generic)) ||
           (length(methods_with_full_name)))
            bad_doc_objects[[docObj]] <-
                list(withGeneric  = methods_with_generic,
                     withFullName = methods_with_full_name)

    }

    attr(bad_doc_objects, "bad_lines") <- bad_lines
    class(bad_doc_objects) <- "checkDocStyle"
    bad_doc_objects
}

format.checkDocStyle <-
function(x, ...)
{
    .fmt <- function(nm) {
        ## <NOTE>
        ## With \method{GENERIC}{CLASS} now being transformed to show
        ## both GENERIC and CLASS info, documenting S3 methods on the
        ## same page as their generic is not necessarily a problem any
        ## more (as one can refer to the generic or the methods in the
        ## documentation, in particular for the primary argument).
        ## Hence, even if we still provide information about this, we
        ## no longer print it by default.  One can still access it via
        ##   lapply(checkDocStyle("foo"), "[[", "withGeneric")
        ## (but of course it does not print that nicely anymore),
        ## </NOTE>
        methods_with_full_name <- x[[nm]][["withFullName"]]
        if(length(methods_with_full_name)) {
            c(gettextf("S3 methods shown with full name in documentation object '%s':",
                       nm),
              .pretty_format(methods_with_full_name),
              "")
        } else {
            character()
        }
    }

    as.character(unlist(lapply(names(x), .fmt)))
}


### * checkFF

checkFF <-
function(package, dir, file, lib.loc = NULL,
         registration = FALSE, check_DUP = FALSE,
         verbose = getOption("verbose"))
{
    allow_suppress <- !nzchar(Sys.getenv("_R_CHECK_FF_AS_CRAN_"))
    suppressCheck <- function(e)
        allow_suppress &&
            length(e) == 2L && is.call(e) && is.symbol(e[[1L]]) &&
                as.character(e[[1L]]) == "dontCheck"

    has_namespace <- FALSE
    is_installed_msg <- is_installed <- FALSE
    ## Argument handling.
    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        dir <- find.package(package, lib.loc)
        dfile <- file.path(dir, "DESCRIPTION")
        db <- .read_description(dfile)
        pkg <- pkgDLL <- basename(dir)
        ## Using package installed in @code{dir} ...
        code_dir <- file.path(dir, "R")
        if(!file_test("-d", code_dir))
            stop(gettextf("directory '%s' does not contain R code",
                          dir),
                 domain = NA)
        have_registration <- FALSE
        if(basename(dir) != "base") {
            .load_package_quietly(package, lib.loc)
            code_env <- asNamespace(package)
            if(exists("DLLs", envir = code_env$.__NAMESPACE__.)) {
                DLLs <- get("DLLs", envir = code_env$.__NAMESPACE__.)
                ## fake installs have this, of class DLLInfoList
                if(length(DLLs)) has_namespace <- TRUE
                if(length(DLLs) && inherits(DLLs[[1L]], "DLLInfo")) {
                    pkgDLL <- unclass(DLLs[[1L]])$name # different for data.table
                    if(registration) {
                        reg <- getDLLRegisteredRoutines(DLLs[[1L]])
                        have_registration <- sum(sapply(reg, length)) > 0L
                    }
                }
            }
        } else {
            has_namespace <- have_registration <- TRUE
            code_env <-.package_env(package)
        }
        is_installed <- TRUE
    }
    else if(!missing(dir)) {
        have_registration <- FALSE
        ## Using sources from directory @code{dir} ...
        if(!file_test("-d", dir))
            stop(gettextf("directory '%s' does not exist", dir),
                 domain = NA)
        else
            dir <- file_path_as_absolute(dir)
        pkg <- pkgDLL <- basename(dir)
        dfile <- file.path(dir, "DESCRIPTION")
        enc <- NA; db <- NULL
        if(file.exists(dfile)) {
            db <- .read_description(dfile)
            enc <- db["Encoding"]
        }
        if(pkg == "base") has_namespace <- TRUE
        if(file.exists(file.path(dir, "NAMESPACE"))) {
            nm <- parseNamespaceFile(basename(dir), dirname(dir))
            has_namespace <- length(nm$dynlibs) > 0L
        }
        code_dir <- file.path(dir, "R")
        if(!file_test("-d", code_dir))
            stop(gettextf("directory '%s' does not contain R code",
                          dir),
                 domain = NA)
        file <- tempfile()
        on.exit(unlink(file))
        if(!file.create(file)) stop("unable to create ", file, domain = NA)
        if(!all(.file_append_ensuring_LFs(file,
                                          list_files_with_type(code_dir,
                                                               "code"))))
            stop("unable to write code files", domain = NA)
    }
    else if(!missing(file)) {
        pkg <- enc <- NA
    } else
        stop("you must specify 'package', 'dir' or 'file'")

    if(missing(package) && !file_test("-f", file))
        stop(gettextf("file '%s' does not exist", file),
             domain = NA)

    ## Should there really be a 'verbose' argument?
    ## It may be useful to extract all foreign function calls but then
    ## we would want the calls back ...
    ## What we currently do is the following: if 'verbose' is true, we
    ## show all foreign function calls in abbreviated form with the line
    ## ending in either 'OK' or 'MISSING', and we return the list of
    ## 'bad' FF calls (i.e., where the 'PACKAGE' argument is missing)
    ## *invisibly* (so that output is not duplicated).
    ## Otherwise, if not verbose, we return the list of bad FF calls.

    bad_exprs <- empty_exprs <- wrong_pkg <- other_problem <- list()
    other_desc <- character()
    bad_pkg <- character()
    dup_false <- list()
    FF_funs <- FF_fun_names <- c(".C", ".Fortran", ".Call", ".External",
                                 ".Call.graphics", ".External.graphics")
    ## As pointed out by DTL, packages could use non-base FF calls for
    ## which missing 'PACKAGE' arguments are not necessarily a problem.
    if(!missing(package)) {
        is_FF_fun_from_base <-
            sapply(FF_funs,
                   function(f) {
                       e <- .find_owner_env(f, code_env)
                       (identical(e, baseenv())
                        || identical(e, .BaseNamespaceEnv))
                   })
        FF_funs <- FF_funs[is_FF_fun_from_base]
    }
    ## Also, need to handle base::.Call() etc ...
    FF_funs <- c(FF_funs, sprintf("base::%s", FF_fun_names))

    allowed <- character()

    check_registration <- function(e, fr) {
    	sym <- e[[2L]]
    	name <- deparse(sym, nlines = 1L)
        if (name == "...")
            return ("SYMBOL OK") # we cannot check this, e.g. RProtoBuf

        if (is.character(sym)) {
            if (!have_registration) return ("SYMBOL OK")
            FF_fun <- as.character(e[[1L]])
            sym <- reg[[FF_fun]][[sym]]
            if(is.null(sym)) return ("SYMBOL OK")
        }

        if (!is_installed) {
            if (!is_installed_msg) {
        	other_problem <<- c(other_problem, e)
        	other_desc <<- c(other_desc, "foreign function registration not tested, as package was not installed")
        	is_installed_msg <<- TRUE
            }
            return("OTHER") # registration checks need the package to be installed
        }
    	if (is.symbol(sym)) { # it might be something like pkg::sym (that's a call)
	    if (!exists(name, code_env, inherits = FALSE)) {
		if (allow_suppress &&
                    name %in% suppressForeignCheck(, package))
		    return ("SYMBOL OK") # skip false positives
                if (have_registration) {
                    if (name %in% fr) {
                        other_problem <<- c(other_problem, e)
                        other_desc <<-
                            c(other_desc,
                              sprintf("symbol %s in the local frame",
                                      sQuote(name)))
                    } else {
                        other_problem <<- c(other_problem, e)
                        other_desc <<-
                            c(other_desc,
                              sprintf("symbol %s not in namespace",
                                      sQuote(name)))
                    }
                }
    	    	return("OTHER")
    	    }
    	} else if (suppressCheck(sym))
    	    return("SKIPPED")

    	sym <- tryCatch(eval(sym, code_env), error = function(e) e)
    	if (inherits(sym, "error")) {
            if (have_registration || !allow_suppress)  {
                other_problem <<- c(other_problem, e)
                other_desc <<-
                    c(other_desc, sprintf("Evaluating %s during check gives error\n%s",
                                          sQuote(name), sQuote(sym$message)))
            }
    	    return("OTHER")
    	}

        FF_fun <- as.character(e[[1L]])
        ## lmom's sym evaluate to character, so try to look up.
        ## FIXME: maybe check this is not PACKAGE = "another package"
        if (is.character(sym)) {
            if (!have_registration) return ("SYMBOL OK")
            sym <- reg[[FF_fun]][[sym]]
            if(is.null(sym)) return ("SYMBOL OK")
        }

        ## These are allowed and used by SU's packages so skip for now
    	if (inherits(sym, "RegisteredNativeSymbol")
            || inherits(sym, "NativeSymbol"))
            return ("SYMBOL OK")

        if (!inherits(sym, "NativeSymbolInfo")) {
    	    other_problem <<- c(other_problem, e)
            ## other_desc <<- c(other_desc, sprintf("\"%s\" is not of class \"%s\"", name, "NativeSymbolInfo"))
    	    other_desc <<- c(other_desc, sprintf("%s is of class \"%s\"",
                                                 sQuote(name), class(sym)))
    	    return("OTHER")
    	}
        ## This might be symbol from another (base?) package.
        ## Allow for Rcpp modules
        parg <- unclass(sym$dll)$name
        if(length(parg) == 1L && ! parg %in% c("Rcpp", pkgDLL)) {
            wrong_pkg <<- c(wrong_pkg, e)
            bad_pkg <<- c(bad_pkg, parg)
        }
    	numparms <- sym$numParameters
        if (length(numparms) && numparms >= 0) {
            ## We have to be careful if ... is in the call.
            if (any(as.character(e) == "...")) {
                other_problem <<- c(other_problem, e)
                other_desc <<-
                    c(other_desc,
                      sprintf("call includes ..., expected %d %s",
                              numparms,
                              if(numparms > 1L) "parameters" else "parameter"))
            } else {
                callparms <- length(e) - 2L
                if ("PACKAGE" %in% names(e)) callparms <- callparms - 1L
                if (FF_fun %in% c(".C", ".Fortran"))
                    callparms <- callparms - length(intersect(names(e), c("NAOK", "DUP", "ENCODING")))
                if (!is.null(numparms) && numparms >= 0L && numparms != callparms) {
                    other_problem <<- c(other_problem, e)
                    other_desc <<-
                        c(other_desc,
                          sprintf("call to %s with %d %s, expected %d",
                                  sQuote(name), callparms,
                                  if(callparms > 1L) "parameters" else "parameter",
                                  numparms))
                    return("OTHER")
                }
            }
        }
    	if (inherits(sym, "CallRoutine") && !(FF_fun %in% c(".Call", ".Call.graphics"))) {
    	    other_problem <<- c(other_problem, e)
    	    other_desc <<- c(other_desc, sprintf("%s registered as %s, but called with %s", sQuote(name), ".Call", FF_fun))
    	    return("OTHER")
    	}
    	if (inherits(sym, "ExternalRoutine") && !(FF_fun %in% c(".External", ".External.graphics"))) {
	    other_problem <<- c(other_problem, e)
	    other_desc <<- c(other_desc, sprintf("%s registered as %s, but called with %s", sQuote(name), ".External", FF_fun))
	    return("OTHER")
	}

        "SYMBOL OK"
    }

    find_bad_exprs <- function(e) {
        if(is.call(e) || is.expression(e)) {
            ## <NOTE>
            ## This picks up all calls, e.g. a$b, and they may convert
            ## to a vector.  The function is the first element in all
            ## the calls we are interested in.
            ## BDR 2002-11-28
            ## </NOTE>
            if(deparse(e[[1L]])[1L] %in% FF_funs) {
                if(registration) check_registration(e, fr)
                dup <- e[["DUP"]]
                if(identical(dup, FALSE))
                    dup_false <<- c(dup_false, e)
                this <- ""
                this <- parg <- e[["PACKAGE"]]
                if (!is.na(pkg) && is.character(parg) &&
                    nzchar(parg) && parg != pkgDLL) {
                    wrong_pkg <<- c(wrong_pkg, e)
                    bad_pkg <<- c(bad_pkg, this)
                }
                parg <- if(!is.null(parg) && (parg != "")) "OK"
                else if(identical(parg, "")) {
                    empty_exprs <<- c(empty_exprs, e)
                    "EMPTY"
                } else if(!is.character(sym <- e[[2L]])) {
                    if (!registration) {
                        sym <- tryCatch(eval(sym, code_env),
                                        error = function(e) e)
                        if (inherits(sym, "NativeSymbolInfo")) {
                            ## This might be symbol from another package.
                            ## Allow for Rcpp modules
                            parg <- unclass(sym$dll)$name
                            if(length(parg) == 1L && !parg %in% c("Rcpp", pkgDLL)) {
                                wrong_pkg <<- c(wrong_pkg, e)
                                bad_pkg <<- c(bad_pkg, parg)
                            }
                        }
                    }
                    "Called with symbol"
                } else if(!has_namespace) {
                    bad_exprs <<- c(bad_exprs, e)
                    "MISSING"
                } else "MISSING but in a function in a namespace"
                if(verbose)
                    if(is.null(this))
                        cat(deparse(e[[1L]]), "(", deparse(e[[2L]]),
                            ", ... ): ", parg, "\n", sep = "")
                    else
                        cat(deparse(e[[1L]]), "(", deparse(e[[2L]]),
                            ", ..., PACKAGE = \"", this, "\"): ",
                            parg, "\n", sep = "")
            } else if (deparse(e[[1L]])[1L] %in% "<-") {
                fr <<- c(fr, as.character(e[[2L]]))
            }
            for(i in seq_along(e)) Recall(e[[i]])
        }
    }

    if(!missing(package)) {
        checkFFmy <- function(f)
            if(typeof(f) == "closure") {
                env <- environment(f)
                if(isNamespace(env)) {
                    nm <- getNamespaceName(env)
                    if (nm == package) body(f) else NULL
                } else body(f)
            } else NULL
        exprs <- lapply(ls(envir = code_env, all.names = TRUE),
                        function(f) {
                            f <- get(f, envir = code_env) # get is expensive
                            checkFFmy(f)
                        })
        if(.isMethodsDispatchOn()) {
            ## Also check the code in S4 methods.
            ## This may find things twice if a setMethod() with a bad FF
            ## call is from inside a function (e.g., InitMethods()).
            for(f in .get_S4_generics(code_env)) {
                mlist <- .get_S4_methods_list(f, code_env)
                exprs <- c(exprs, lapply(mlist, body))
            }
            refs <- .get_ref_classes(code_env)
            if(length(refs)) {
                exprs2 <- lapply(unlist(refs, FALSE), checkFFmy)
                exprs <- c(exprs, exprs2)
            }
        }
    } else {
        if(!is.na(enc) &&
           !(Sys.getlocale("LC_CTYPE") %in% c("C", "POSIX"))) {
            ## FIXME: what if conversion fails on e.g. UTF-8 comments
	    con <- file(file, encoding=enc)
            on.exit(close(con))
	} else con <- file
        exprs <-
            tryCatch(parse(file = con, n = -1L),
                     error = function(e)
                     stop(gettextf("parse error in file '%s':\n%s",
                                   file,
                                   .massage_file_parse_error_message(conditionMessage(e))),
                          domain = NA, call. = FALSE))
    }
    for(i in seq_along(exprs)) {
        fr <- character()
        find_bad_exprs(exprs[[i]])
    }
    attr(bad_exprs, "wrong_pkg") <- wrong_pkg
    attr(bad_exprs, "bad_pkg") <- bad_pkg
    attr(bad_exprs, "empty") <- empty_exprs
    attr(bad_exprs, "other_problem") <- other_problem
    attr(bad_exprs, "other_desc") <- other_desc
    if(check_DUP) attr(bad_exprs, "dup_false") <- dup_false
    if (length(bad_pkg)) {              # check against dependencies.
        bases <- .get_standard_package_names()$base
        bad <- bad_pkg[!bad_pkg %in% bases]
        if (length(bad)) {
            depends <- .get_requires_from_package_db(db, "Depends")
            imports <- .get_requires_from_package_db(db, "Imports")
            suggests <- .get_requires_from_package_db(db, "Suggests")
            enhances <- .get_requires_from_package_db(db, "Enhances")
            bad <- bad[!bad %in% c(depends, imports, suggests, enhances)]
            attr(bad_exprs, "undeclared") <- bad
        }
    }
    class(bad_exprs) <- "checkFF"
    if(verbose)
        invisible(bad_exprs)
    else
        bad_exprs
}

format.checkFF <-
function(x, ...)
{
    xx <- attr(x, "empty")
    y <- attr(x, "wrong_pkg")
    z <- attr(x, "bad_pkg")
    zz <- attr(x, "undeclared")
    other_problem <- attr(x, "other_problem")

    res <- character()
    if (length(x)) {
        .fmt <- function(x)
            paste0("  ", deparse(x[[1L]]), "(", deparse(x[[2L]]), ", ...)")
        msg <- ngettext(length(x),
                        "Foreign function call without 'PACKAGE' argument:",
                        "Foreign function calls without 'PACKAGE' argument:",
                        domain = NA)
        res <- c(msg, unlist(lapply(x, .fmt)))
    }
    if (length(xx)) {
        .fmt <- function(x)
            paste0("  ", deparse(x[[1L]]), "(", deparse(x[[2L]]), ", ...)")
        msg <- ngettext(length(x),
                        "Foreign function call with empty 'PACKAGE' argument:",
                        "Foreign function calls with empty 'PACKAGE' argument:",
                        domain = NA)
       res <- c(res, msg, unlist(lapply(xx, .fmt)))
    }

    if (length(y)) {
        bases <- .get_standard_package_names()$base
        .fmt2 <- function(x, z) {
            if("PACKAGE" %in% names(x))
                paste0("  ", deparse(x[[1L]]), "(", deparse(x[[2L]]),
                       ", ..., PACKAGE = \"", z, "\")")
            else
                paste0("  ", deparse(x[[1L]]), "(", deparse(x[[2L]]), ", ...)")
        }
        base <- z %in% bases
        if(any(base)) {
            xx <- unlist(lapply(seq_along(y)[base],
                                function(i) .fmt2(y[[i]], z[i])))
            xx <- unique(xx)
            msg <- ngettext(length(xx),
                            "Foreign function call to a base package:",
                            "Foreign function calls to a base package:",
                            domain = NA)
            res <- c(res, msg, sort(xx))
        }
        if(any(!base)) {
            xx <-  unlist(lapply(seq_along(y)[!base],
                                 function(i) .fmt2(y[[i]], z[i])))
            xx <- unique(xx)
            msg <- ngettext(length(xx),
                            "Foreign function call to a different package:",
                            "Foreign function calls to a different package:",
                            domain = NA)
            res <- c(res, msg, sort(xx))
        }
    }
    if (length(zz)) {
        zz <- unique(zz)
        msg <- ngettext(length(zz),
                        "Undeclared package in foreign function calls:",
                        "Undeclared packages in foreign function calls:",
                        domain = NA)
        res <- c(res, msg, paste("  ", paste(sQuote(sort(zz)), collapse = ", ")))
    }
    if (length(other_problem)) {
    	msg <- ngettext(length(other_problem),
    		        "Registration problem:",
    		        "Registration problems:",
    		        domain = NA)
        res <- c(res, msg)
        other_desc <- attr(x, "other_desc")
        for (i in seq_along(other_problem)) {
            res <- c(res, paste0("  ", other_desc[i], ":"),
                          paste0("   ", deparse(other_problem[[i]])))
        }
    }
    z3 <- attr(x, "dup_false")
     if (length(z3)) {
    	msg <- ngettext(length(z3),
    		        "Call with DUP = FALSE:",
    		        "Calls with DUP = FALSE:",
    		        domain = NA)
        res <- c(res, msg)
        for (i in seq_along(z3)) {
            res <- c(res, paste0("   ", deparse(z3[[i]])))
        }
    }
   res
}

### * checkS3methods

checkS3methods <-
function(package, dir, lib.loc = NULL)
{
    has_namespace <- FALSE
    ## If an installed package has a namespace, we need to record the S3
    ## methods which are registered but not exported (so that we can
    ## get() them from the right place).
    S3_reg <- character()

    ## Argument handling.
    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        dir <- find.package(package, lib.loc)
        ## Using package installed in @code{dir} ...
        code_dir <- file.path(dir, "R")
        if(!file_test("-d", code_dir))
            stop(gettextf("directory '%s' does not contain R code",
                          dir),
                 domain = NA)
        is_base <- basename(dir) == "base"

        ## Load package into code_env.
        if(!is_base)
            .load_package_quietly(package, lib.loc)
        code_env <- .package_env(package)

        objects_in_code <- objects(envir = code_env, all.names = TRUE)

        ## Does the package have a namespace?
        if(packageHasNamespace(package, dirname(dir))) {
            has_namespace <- TRUE
            ## Determine names of declared S3 methods and associated S3
            ## generics.
            ns_S3_methods_db <- getNamespaceInfo(package, "S3methods")
            ns_S3_generics <- ns_S3_methods_db[, 1L]
            ns_S3_methods <- ns_S3_methods_db[, 3L]
            ## Determine unexported but declared S3 methods.
            S3_reg <- setdiff(ns_S3_methods, objects_in_code)
        }
    }
    else {
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        ## Using sources from directory @code{dir} ...
        if(!file_test("-d", dir))
            stop(gettextf("directory '%s' does not exist", dir),
                 domain = NA)
        else
            dir <- file_path_as_absolute(dir)
        code_dir <- file.path(dir, "R")
        if(!file_test("-d", code_dir))
            stop(gettextf("directory '%s' does not contain R code",
                          dir),
                 domain = NA)
        is_base <- basename(dir) == "base"

        code_env <- new.env(hash = TRUE)
        dfile <- file.path(dir, "DESCRIPTION")
        meta <- if(file_test("-f", dfile))
            .read_description(dfile)
        else
            character()
        .source_assignments_in_code_dir(code_dir, code_env, meta)
        sys_data_file <- file.path(code_dir, "sysdata.rda")
        if(file_test("-f", sys_data_file)) load(sys_data_file, code_env)

        objects_in_code <- objects(envir = code_env, all.names = TRUE)

        ## Does the package have a NAMESPACE file?
        if(file.exists(file.path(dir, "NAMESPACE"))) {
            has_namespace <- TRUE
            nsInfo <- parseNamespaceFile(basename(dir), dirname(dir))
            ## Determine exported objects.
            OK <- intersect(objects_in_code, nsInfo$exports)
            for(p in nsInfo$exportPatterns)
                OK <- c(OK, grep(p, objects_in_code, value = TRUE))
            objects_in_code <- unique(OK)
            ## Determine names of declared S3 methods and associated S3
            ## generics.
            ns_S3_methods_db <- .get_namespace_S3_methods_db(nsInfo)
            ns_S3_generics <- ns_S3_methods_db[, 1L]
            ns_S3_methods <- ns_S3_methods_db[, 3L]
        }

    }

    ## Find the function objects in the given package.
    functions_in_code <-
        Filter(function(f) is.function(get(f, envir = code_env)), # get is expensive
               objects_in_code)

    ## This is the virtual groyp generics, not the members
    S3_group_generics <- .get_S3_group_generics()
    ## This includes the primitive group generics as from R 2.6.0
    S3_primitive_generics <- .get_S3_primitive_generics()

    checkArgs <- function(g, m) {
        ## Do the arguments of method m (in code_env) 'extend' those of
        ## the generic g as seen from code_env?  The method must have all
        ## arguments the generic has, with positional arguments of g in
        ## the same positions for m.
        ## Exception: '...' in the method swallows anything.
        genfun <- get(g, envir = code_env)
        gArgs <- names(formals(genfun))
        if(g == "plot") gArgs <- gArgs[-2L]
        ogArgs <- gArgs
        gm <- if(m %in% S3_reg) {
            ## See registerS3method() in ../../base/R/namespace.R.
            defenv <-
                if (g %in% S3_group_generics || g %in% S3_primitive_generics)
                    .BaseNamespaceEnv
                else {
                    if(.isMethodsDispatchOn()
                       && methods:::is(genfun, "genericFunction"))
                        genfun <- methods:::finalDefaultMethod(genfun@default)
                    if (typeof(genfun) == "closure") environment(genfun)
                    else .BaseNamespaceEnv
                }
            if(!exists(".__S3MethodsTable__.", envir = defenv,
                       inherits = FALSE)) {
                ## Happens e.g. if for some reason, we get "plot" as
                ## standardGeneric for "plot" defined from package
                ## "graphics" with its own environment which does not
                ## contain an S3 methods table ...
                return(NULL)
            }
            S3Table <- get(".__S3MethodsTable__.", envir = defenv,
                           inherits = FALSE)
            if(!exists(m, envir = S3Table)) {
                warning(gettextf("declared S3 method '%s' not found",
                                 m),
                        domain = NA,
                        call. = FALSE)
                return(NULL)
            } else get(m, envir = S3Table)
        } else get(m, envir = code_env)
        mArgs <- omArgs <- names(formals(gm))
        ## If m is a formula method, its first argument *may* be called
        ## formula.  (Note that any argument name mismatch throws an
        ## error in current S-PLUS versions.)
        if(length(grep("\\.formula$", m))) {
            if(gArgs[1L] != "...") gArgs <- gArgs[-1L]
            mArgs <- mArgs[-1L]
        }
        dotsPos <- which(gArgs == "...")
        ipos <- if(length(dotsPos))
            seq.int(from = 1L, length.out = dotsPos[1L] - 1L)
        else
            seq_along(gArgs)

        ## careful, this could match multiply in incorrect funs.
        dotsPos <- which(mArgs == "...")
        if(length(dotsPos))
            ipos <- ipos[seq.int(from = 1L, length.out = dotsPos[1L] - 1L)]
        posMatchOK <- identical(gArgs[ipos], mArgs[ipos])
        argMatchOK <- all(gArgs %in% mArgs) || length(dotsPos) > 0L
        margMatchOK <- all(mArgs %in% c("...", gArgs)) || "..." %in% ogArgs
        if(posMatchOK && argMatchOK && margMatchOK)
            NULL
        else if (g %in% c("+", "-", "*", "/", "^", "%%", "%/%", "&", "|",
                          "!", "==", "!=", "<", "<=", ">=", ">")
                 && (length(ogArgs) == length(omArgs)) )
            NULL
        else {
            l <- list(ogArgs, omArgs)
            names(l) <- c(g, m)
            list(l)
        }
    }

    all_S3_generics <-
        unique(c(Filter(function(f) .is_S3_generic(f, envir = code_env),
                        functions_in_code),
                 .get_S3_generics_as_seen_from_package(dir,
                                                       !missing(package),
                                                       FALSE),
                 S3_group_generics, S3_primitive_generics))
    ## <FIXME>
    ## Not yet:
    code_env <- .make_S3_group_generic_env(parent = code_env)
    ## </FIXME>
    code_env <- .make_S3_primitive_generic_env(parent = code_env)

    ## Now determine the 'bad' methods in the function objects of the
    ## package.
    bad_methods <- list()
    methods_stop_list <- .make_S3_methods_stop_list(basename(dir))
    for(g in all_S3_generics) {
        if(!exists(g, envir = code_env)) next
        ## Find all methods in functions_in_code for S3 generic g.
        ## <FIXME>
        ## We should really determine the name g dispatches for, see
        ## a current version of methods() [2003-07-07].  (Care is
        ## needed for internal generics and group generics.)
        ## Matching via grep() is tricky with e.g. a '$' in the name
        ## of the generic function ... hence substr().
        name <- paste0(g, ".")
        methods <-
            functions_in_code[substr(functions_in_code, 1L,
                                     nchar(name, type="c")) == name]
        ## </FIXME>
        methods <- setdiff(methods, methods_stop_list)
        if(has_namespace) {
            ## Find registered methods for generic g.
            methods <- c(methods, ns_S3_methods[ns_S3_generics == g])
        }

        for(m in methods)
            ## Both all() and all.equal() are generic.
            bad_methods <- if(g == "all") {
                m1 <- m[-grep("^all\\.equal", m)]
                c(bad_methods, if(length(m1)) checkArgs(g, m1))
            } else c(bad_methods, checkArgs(g, m))
    }

    class(bad_methods) <- "checkS3methods"
    bad_methods
}

format.checkS3methods <-
function(x, ...)
{
    format_args <- function(s)
        paste0("function(", paste(s, collapse = ", "), ")")

    .fmt <- function(entry) {
        c(paste0(names(entry)[1L], ":"),
          strwrap(format_args(entry[[1L]]), indent = 2L, exdent = 11L),
          paste0(names(entry)[2L], ":"),
          strwrap(format_args(entry[[2L]]), indent = 2L, exdent = 11L),
          "")
    }

    as.character(unlist(lapply(x, .fmt)))
}

### * checkReplaceFuns

checkReplaceFuns <-
function(package, dir, lib.loc = NULL)
{
    has_namespace <- FALSE

    ## Argument handling.
    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        dir <- find.package(package, lib.loc)
        ## Using package installed in @code{dir} ...
        code_dir <- file.path(dir, "R")
        if(!file_test("-d", code_dir))
            stop(gettextf("directory '%s' does not contain R code",
                          dir),
                 domain = NA)
        is_base <- basename(dir) == "base"

        ## Load package into code_env.
        if(!is_base)
            .load_package_quietly(package, lib.loc)
        ## In case the package has a namespace, we really want to check
        ## all replacement functions in the package.  (If not, we need
        ## to change the code for the non-installed case to only look at
        ## exported (replacement) functions.)
        if(packageHasNamespace(package, dirname(dir))) {
            has_namespace <- TRUE
            code_env <- asNamespace(package)
            ns_S3_methods_db <- getNamespaceInfo(package, "S3methods")
        }
        else
            code_env <- .package_env(package)
    }

    else {
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        ## Using sources from directory @code{dir} ...
        if(!file_test("-d", dir))
            stop(gettextf("directory '%s' does not exist", dir),
                 domain = NA)
        else
            dir <- file_path_as_absolute(dir)
        code_dir <- file.path(dir, "R")
        if(!file_test("-d", code_dir))
            stop(gettextf("directory '%s' does not contain R code",
                          dir),
                 domain = NA)
        is_base <- basename(dir) == "base"

        code_env <- new.env(hash = TRUE)
        dfile <- file.path(dir, "DESCRIPTION")
        meta <- if(file_test("-f", dfile))
            .read_description(dfile)
        else
            character()
        .source_assignments_in_code_dir(code_dir, code_env, meta)
        sys_data_file <- file.path(code_dir, "sysdata.rda")
        if(file_test("-f", sys_data_file)) load(sys_data_file, code_env)

        ## Does the package have a NAMESPACE file?  Note that when
        ## working on the sources we (currently?) cannot deal with the
        ## (experimental) alternative way of specifying the namespace.
        if(file.exists(file.path(dir, "NAMESPACE"))) {
            has_namespace <- TRUE
            nsInfo <- parseNamespaceFile(basename(dir), dirname(dir))
            ns_S3_methods_db <- .get_namespace_S3_methods_db(nsInfo)
        }
    }

    objects_in_code <- objects(envir = code_env, all.names = TRUE)
    replace_funs <- character()

    if(has_namespace) {
        ns_S3_generics <- ns_S3_methods_db[, 1L]
        ns_S3_methods <- ns_S3_methods_db[, 3L]
        ## S3 replacement methods from namespace registration?
        idx <- grep("<-$", ns_S3_generics)
        if(length(idx)) replace_funs <- ns_S3_methods[idx]
        ## Now remove the functions registered as S3 methods.
        objects_in_code <- setdiff(objects_in_code, ns_S3_methods)
    }

    replace_funs <-
        c(replace_funs, grep("<-", objects_in_code, value = TRUE))

    .check_last_formal_arg <- function(f) {
        arg_names <- names(formals(f))
        if(!length(arg_names))
            TRUE                        # most likely a .Primitive()
        else
            identical(arg_names[length(arg_names)], "value")
    }

    ## Find the replacement functions (which have formal arguments) with
    ## last arg not named 'value'.
    bad_replace_funs <- if(length(replace_funs)) {
        Filter(function(f) {
                   ## Always get the functions from code_env ...
                   ## Should maybe get S3 methods from the registry ...
                   f <- get(f, envir = code_env)  # get is expensive
                   if(!is.function(f)) return(FALSE)
                   ! .check_last_formal_arg(f)
               },
               replace_funs)
    } else character()

    if(.isMethodsDispatchOn()) {
        S4_generics <- .get_S4_generics(code_env)
        ## Assume that the ones with names ending in '<-' are always
        ## replacement functions.
        S4_generics <- S4_generics[grepl("<-$", names(S4_generics))]
        bad_S4_replace_methods <-
            sapply(S4_generics,
                   function(f) {
                       mlist <- .get_S4_methods_list(f, code_env)
                       ind <- !as.logical(sapply(mlist,
                                                 .check_last_formal_arg))
                       if(!any(ind))
                           character()
                       else {
                           sigs <- .make_siglist(mlist[ind])
                           sprintf("\\S4method{%s}{%s}", f, sigs)
                       }
                   })
        bad_replace_funs <-
            c(bad_replace_funs,
              unlist(bad_S4_replace_methods, use.names = FALSE))
    }

    class(bad_replace_funs) <- "checkReplaceFuns"
    bad_replace_funs
}

format.checkReplaceFuns <-
function(x, ...)
{
    if(length(x))
        .pretty_format(unclass(x))
    else
        character()
}

### * checkTnF

checkTnF <-
function(package, dir, file, lib.loc = NULL)
{
    code_files <- docs_files <- character()

    ## Argument handling.
    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        ## Using package installed in @code{dir} ...
        dir <- find.package(package, lib.loc)
        if(file.exists(file.path(dir, "R", "all.rda"))) {
            warning("cannot check R code installed as image")
        }
        code_file <- file.path(dir, "R", package)
        if(file.exists(code_file))      # could be data-only
            code_files <- code_file
        example_dir <- file.path(dir, "R-ex")
        if(file_test("-d", example_dir)) {
            code_files <- c(code_files,
                            list_files_with_exts(example_dir, "R"))
        }
    }
    else if(!missing(dir)) {
        ## Using sources from directory @code{dir} ...
        if(!file_test("-d", dir))
            stop(gettextf("directory '%s' does not exist", dir),
                 domain = NA)
        else
            dir <- file_path_as_absolute(dir)
        code_dir <- file.path(dir, "R")
        if(file_test("-d", code_dir))   # could be data-only
            code_files <- list_files_with_type(code_dir, "code")
        docs_dir <- file.path(dir, "man")
        if(file_test("-d", docs_dir))
            docs_files <- list_files_with_type(docs_dir, "docs")
    }
    else if(!missing(file)) {
        if(!file_test("-f", file))
            stop(gettextf("file '%s' does not exist", file),
                 domain = NA)
        else
            code_files <- file
    }
    else
        stop("you must specify 'package', 'dir' or 'file'")

    find_TnF_in_code <- function(file, txt) {
        ## If 'txt' is given, it contains the extracted examples from
        ## the R documentation file 'file'.  Otherwise, 'file' gives a
        ## file with (just) R code.
        matches <- list()
        TnF <- c("T", "F")
        find_bad_exprs <- function(e, p) {
            if(is.name(e)
               && (as.character(e) %in% TnF)
               && !is.null(p)) {
                ## Need the 'list()' to deal with T/F in function
                ## arglists which are pairlists ...
                matches <<- c(matches, list(p))
            }
            else if(is.recursive(e)) {
                for(i in seq_along(e)) Recall(e[[i]], e)
            }
        }
        exprs <- if(missing(txt))
            tryCatch(parse(file = file, n = -1L),
                     error = function(e)
                     stop(gettextf("parse error in file '%s':\n",
                                   file,
                                   .massage_file_parse_error_message(conditionMessage(e))),
                          domain = NA, call. = FALSE))
        else
            tryCatch(parse(text = txt),
                     error = function(e)
                     stop(gettextf("parse error in examples from file '%s':\n",
                                   file, conditionMessage(e)),
                          domain = NA, call. = FALSE))
        for(i in seq_along(exprs))
            find_bad_exprs(exprs[[i]], NULL)
        matches
    }

    bad_exprs <- list()
    for(file in code_files) {
        exprs <- find_TnF_in_code(file)
        if(length(exprs)) {
            exprs <- list(exprs)
            names(exprs) <- file
            bad_exprs <- c(bad_exprs, exprs)
        }
    }
    for(file in docs_files) {
        Rd <- prepare_Rd(file, defines = .Platform$OS.type)
        txt <- .Rd_get_example_code(Rd)
        exprs <- find_TnF_in_code(file, txt)
        if(length(exprs)) {
            exprs <- list(exprs)
            names(exprs) <- file
            bad_exprs <- c(bad_exprs, exprs)
        }
    }
    class(bad_exprs) <- "checkTnF"
    bad_exprs
}

format.checkTnF <-
function(x, ...)
{
    .fmt <- function(fname) {
        xfname <- x[[fname]]
        c(gettextf("File '%s':", fname),
          unlist(lapply(seq_along(xfname),
                        function(i) {
                            strwrap(gettextf("found T/F in %s",
                                             paste(deparse(xfname[[i]]),
                                                   collapse = "")),
                                    exdent = 4L)
                        })),
          "")
    }

    as.character(unlist(lapply(names(x), .fmt)))
}

### * .check__depends

## changed in 2.3.0 to refer to a source dir.


.check_package_depends <-
function(dir, force_suggests = TRUE, check_incoming = FALSE)
{
    .check_dependency_cycles <-
        function(db, available = available.packages(),
                 dependencies = c("Depends", "Imports", "LinkingTo"))
        {
            ## given a package, find its recursive dependencies.
            ## We want the dependencies of the current package,
            ## not of a version on the repository.
            pkg <- db[["Package"]]
            this <- db[dependencies]; names(this) <- dependencies;
            known <- setdiff(utils:::.clean_up_dependencies(this), "R")
            info <- available[, dependencies, drop = FALSE]
            rn <- rownames(info)
            deps <- function(p) {
                if(!(p %in% rn)) return(character())
                this <- utils:::.clean_up_dependencies(info[p, ])
                setdiff(this, "R")
            }
            extra <- known
            repeat {
                extra <- unlist(lapply(extra, deps))
                extra <- setdiff(extra, known)
                if(!length(extra)) break
                known <- c(known, extra)
            }
            known
        }

    if(length(dir) != 1L)
        stop("argument 'package' must be of length 1")

    ## We definitely need a valid DESCRIPTION file.
    db <- .read_description(file.path(dir, "DESCRIPTION"))

    dir_name <- basename(dir)
    package_name <- db["Package"]
    if(!identical(package_name, dir_name) &&
       (!is.character(package_name) || !nzchar(package_name))) {
	message(sprintf(
            "package name '%s' seems invalid; using directory name '%s' instead",
            package_name, dir_name))
	package_name <- dir_name
    }

    bad_depends <- list()
    ## and we cannot have cycles
    ## this check needs a package db from repository(s), so
    if(!any(grepl("@CRAN@", getOption("repos")))) {
        ad <- .check_dependency_cycles(db)
        pkgname <- db[["Package"]]
        if(pkgname %in% ad)
            bad_depends$all_depends <- setdiff(ad, pkgname)
    } else if (check_incoming)
        bad_depends$skipped <-
            "  No repository set, so cyclic dependency check skipped"

    ldepends <-  .get_requires_with_version_from_package_db(db, "Depends")
    limports <-  .get_requires_with_version_from_package_db(db, "Imports")
    llinks <-  .get_requires_with_version_from_package_db(db, "LinkingTo")
    lsuggests <- .get_requires_with_version_from_package_db(db, "Suggests")
    ## NB: no one checks version for 'Enhances'.
    lenhances <- .get_requires_with_version_from_package_db(db, "Enhances")

    depends <- sapply(ldepends, `[[`, 1L)
    imports <- sapply(limports, `[[`, 1L)
    links <- sapply(llinks, `[[`, 1L)
    suggests <- sapply(lsuggests, `[[`, 1L)

    standard_package_names <- .get_standard_package_names()

    ## Are all packages listed in Depends/Suggests/Imports/LinkingTo installed?
    lreqs <- c(ldepends, limports, llinks,
               if(force_suggests) lsuggests)
    lreqs2 <- c(if(!force_suggests) lsuggests, lenhances)
    if(length(c(lreqs, lreqs2))) {
        ## Do this directly for speed.
        installed <- character()
        installed_in <- character()
        for(lib in .libPaths()) {
            pkgs <- list.files(lib)
            pkgs <- pkgs[file.access(file.path(lib, pkgs, "DESCRIPTION"), 4) == 0]
            installed <- c(installed, pkgs)
            installed_in <- c(installed_in, rep.int(lib, length(pkgs)))
        }
        if (length(lreqs)) {
            reqs <- unique(sapply(lreqs, `[[`, 1L))
            reqs <- setdiff(reqs, installed)
            m <- reqs %in% standard_package_names$stubs
            if(length(reqs[!m])) {
                bad <- reqs[!m]
                ## EDanalysis has a package in all of Depends, Imports, Suggests.
                bad1 <-  bad[bad %in% c(depends, imports, links)]
                if(length(bad1))
                    bad_depends$required_but_not_installed <- bad1
                bad2 <-  setdiff(bad, bad1)
                if(length(bad2))
                    bad_depends$suggested_but_not_installed <- bad2
            }
            if(length(reqs[m]))
                bad_depends$required_but_stub <- reqs[m]
            ## now check versions
            have_ver <- unlist(lapply(lreqs, function(x) length(x) == 3L))
            lreqs3 <- lreqs[have_ver]
            if(length(lreqs3)) {
                bad <- character()
                for (r in lreqs3) {
                    pkg <- r[[1L]]
                    op <- r[[2L]]
                    where <- which(installed == pkg)
                    if(!length(where)) next
                    ## want the first one
                    desc <- readRDS(file.path(installed_in[where[1L]], pkg,
                                              "Meta", "package.rds"))
                    current <- desc$DESCRIPTION["Version"]
                    target <- as.package_version(r[[3L]])
                    if(eval(parse(text = paste("!(current", op, "target)"))))
                        bad <- c(bad, pkg)
                }
                if(length(bad))
                    bad_depends$required_but_obsolete <- bad
            }
        }
        if (length(lenhances)) {
            m <- setdiff(sapply(lenhances, `[[`, 1L), installed)
            if(length(m))
                bad_depends$enhances_but_not_installed <- m
        }
        if (!force_suggests && length(lsuggests)) {
            m <- setdiff(sapply(lsuggests, `[[`, 1L), installed)
            if(length(m))
                bad_depends$suggests_but_not_installed <- m
        }
    }
    ## FIXME: is this still needed now we do dependency analysis?
    ## Are all vignette dependencies at least suggested or equal to
    ## the package name?

    ## This is a check for old-location vignettes.
    ## If the package itself is the VignetteBuilder,
    ## we may not have installed it yet.
    defer <- package_name %in%  db["VignetteBuilder"]
    vigns <- pkgVignettes(dir = dir, subdirs = file.path("inst", "doc"),
                          check = !defer)

    if(length(vigns$msg))
        bad_depends$bad_engine <- vigns$msg
    if (!is.null(vigns) && length(vigns$docs) > 0L) {
        reqs <- unique(unlist(.build_vignette_index(vigns)$Depends))
        ## For the time being, ignore base packages missing from the
        ## DESCRIPTION dependencies even if explicitly given as vignette
        ## dependencies.
        reqs <- setdiff(reqs,
                        c(depends, imports, suggests, package_name,
                          standard_package_names$base))
        if(length(reqs))
            bad_depends$missing_vignette_depends <- reqs
    }

    ## Are all namespace dependencies listed as package dependencies?
    if(file_test("-f", file.path(dir, "NAMESPACE"))) {
        reqs <- .get_namespace_package_depends(dir)
        ## <FIXME>
        ## Not clear whether we want to require *all* namespace package
        ## dependencies listed in DESCRIPTION, or e.g. just the ones on
        ## non-base packages.  Do the latter for time being ...
        ## Actually we need to know at least about S4-using packages,
        ## since we need to reinstall if those change.
        allowed_imports <-
            setdiff(standard_package_names$base, c("methods", "stats4"))
        reqs <- setdiff(reqs, c(imports, depends, allowed_imports))
        if(length(reqs))
            bad_depends$missing_namespace_depends <- reqs
    }

    ## Check for excessive 'Depends'
    deps <- setdiff(depends, c("R", "base", "datasets", "grDevices",
                               "graphics", "methods", "utils", "stats"))
    if(length(deps) > 5L) bad_depends$many_depends <- deps

    ## check header-only packages
    if (check_incoming) {
        hdOnly <- c("BH", "RcppArmadillo", "RcppEigen")
        hd <- intersect(hdOnly, c(depends, imports))
        if(length(hd)) bad_depends$hdOnly <- hd
    }

    class(bad_depends) <- "check_package_depends"
    bad_depends
}

format.check_package_depends <-
function(x, ...)
{
    c(character(),
      if(length(x$skipped)) c(x$skipped, ""),
      if(length(x$all_depends)) {
          c("There is circular dependency in the installation order:",
            .pretty_format2("  One or more packages in", x$all_depends),
            "  depend on this package (for the versions on the repositories).",
            "")
      },
      if(length(bad <- x$required_but_not_installed) > 1L) {
          c(.pretty_format2("Packages required but not available:", bad), "")
      } else if(length(bad)) {
          c(sprintf("Package required but not available: %s", sQuote(bad)), "")
      },
      if(length(bad <- x$suggested_but_not_installed) > 1L) {
          c(.pretty_format2("Packages suggested but not available:", bad), "")
      } else if(length(bad)) {
          c(sprintf("Package suggested but not available: %s", sQuote(bad)), "")
      },
      if(length(bad <- x$required_but_obsolete) > 1L) {
          c(.pretty_format2("Packages required and available but unsuitable versions:",
                            bad),
            "")
      } else if(length(bad)) {
          c(sprintf("Package required and available but unsuitable version: %s", sQuote(bad)),
            "")
      },
      if(length(bad <- x$required_but_stub) > 1L) {
          c("Former standard packages required but now defunct:",
            .pretty_format(bad),
            "")
      } else if(length(bad)) {
          c(sprintf("Former standard package required but now defunct: %s",
                    sQuote(bad)), "")
      },
      if(length(bad <- x$suggests_but_not_installed) > 1L) {
          c(.pretty_format2("Packages suggested but not available for checking:",
                            bad),
            "")
      } else if(length(bad)) {
          c(sprintf("Package suggested but not available for checking: %s",
                     sQuote(bad)),
            "")
      },
      if(length(bad <- x$enhances_but_not_installed) > 1L) {
          c(.pretty_format2("Packages which this enhances but not available for checking:",
                            bad),
            "")
      } else if(length(bad)) {
          c(sprintf("Package which this enhances but not available for checking: %s", sQuote(bad)),
            "")
      },
      if(length(bad <- x$missing_vignette_depends)) {
          c(if(length(bad) > 1L) {
                c("Vignette dependencies not required:", .pretty_format(bad))
            } else {
                sprintf("Vignette dependencies not required: %s", sQuote(bad))
            },
            strwrap(gettextf("Vignette dependencies (%s entries) must be contained in the DESCRIPTION Depends/Suggests/Imports entries.",
                             "\\VignetteDepends{}")),
            "")
      },
      if(length(bad <- x$missing_namespace_depends) > 1L) {
          c(.pretty_format2("Namespace dependencies not required:", bad), "")
      } else if(length(bad)) {
          c(sprintf("Namespace dependency not required: %s", sQuote(bad)), "")
      },
      if(length(y <- x$many_depends)) {
          c(.pretty_format2("Depends: includes the non-default packages:", y),
            strwrap(paste("Adding so many packages to the search path",
                          "is excessive",
                          "and importing selectively is preferable."
                          , collapse = ", ")),
            "")
      },
      if(length(y <- x$bad_engine)) {
          c(y, "")
      },
      if(length(bad <- x$hdOnly)) {
          c(if(length(bad) > 1L)
            c("Packages in Depends/Imports which should probably only be in LinkingTo:", .pretty_format(bad))
          else
            sprintf("Package in Depends/Imports which should probably only be in LinkingTo: %s", sQuote(bad)),
            "")
      }
      )
  }

### * .check_package_description

.check_package_description <-
function(dfile, strict = FALSE)
{
    dfile <- file_path_as_absolute(dfile)
    db <- .read_description(dfile)

    standard_package_names <- .get_standard_package_names()

    valid_package_name_regexp <-
        .standard_regexps()$valid_package_name
    valid_package_version_regexp <-
        .standard_regexps()$valid_package_version

    is_base_package <-
        !is.na(priority <- db["Priority"]) && priority == "base"

    out <- list()                       # For the time being ...

    ## Check encoding-related things first.

    ## All field tags must be ASCII.
    if(any(ind <- !.is_ASCII(names(db))))
        out$fields_with_non_ASCII_tags <- names(db)[ind]
    ## For all fields used by the R package management system, values
    ## must be ASCII as well (so that the RPM works in a C locale).
    ASCII_fields <- c(.get_standard_repository_db_fields(),
                      "Encoding", "License")
    ASCII_fields <- intersect(ASCII_fields, names(db))
    if(any(ind <- !.is_ASCII(db[ASCII_fields])))
        out$fields_with_non_ASCII_values <- ASCII_fields[ind]

    ## Determine encoding and re-encode if necessary and possible.
    if("Encoding" %in% names(db)) {
        encoding <- db["Encoding"]
        if((! Sys.getlocale("LC_CTYPE") %in% c("C", "POSIX")))
            db <- iconv(db, encoding, sub = "byte")
    }
    else if(!all(.is_ISO_8859(db))) {
        ## No valid Encoding metadata.
        ## Determine whether we can assume Latin1.
        out$missing_encoding <- TRUE
    }

    if(any(is.na(nchar(db, "c", TRUE)))) {
        ## Ouch, invalid in the current locale.
        ## (Can only happen in a MBCS locale.)
        ## Try re-encoding from Latin1.
        db <- iconv(db, "latin1")
    }

    ## Check Authors@R and expansion if needed.
    if(!is.na(aar <- db["Authors@R"]) &&
       (is.na(db["Author"]) || is.na(db["Maintainer"]))) {
        res <- .check_package_description_authors_at_R_field(aar)
        if(is.na(db["Author"]) &&
           !is.null(s <- attr(res, "Author")))
            db["Author"] <- s
        if(is.na(db["Maintainer"]) &&
           !is.null(s <- attr(res, "Maintainer")))
            db["Maintainer"] <- s
        mostattributes(res) <- NULL     # Keep names.
        out <- c(out, res)
    }

    val <- package_name <- db["Package"]
    if(!is.na(val)) {
        tmp <- character()
        ## We allow 'R', which is not a valid package name.
        if(!grepl(sprintf("^(R|%s)$", valid_package_name_regexp), val))
            tmp <- c(tmp, gettext("Malformed package name"))
        if(!is_base_package) {
            if(val %in% standard_package_names$base)
                tmp <- c(tmp,
                         c("Invalid package name.",
                           "This is the name of a base package."))
            else if(val %in% standard_package_names$stubs)
                tmp <- c(tmp,
                         c("Invalid package name.",
                           "This name was used for a base package and is remapped by library()."))
        }
        if(length(tmp))
            out$bad_package <- tmp
    }
    if(!is.na(val <- db["Version"])
       && !is_base_package
       && !grepl(sprintf("^%s$", valid_package_version_regexp), val))
        out$bad_version <- val
    if(!is.na(val <- db["Maintainer"])
       && !grepl(.valid_maintainer_field_regexp, val))
        out$bad_maintainer <- val

    ## Optional entries in DESCRIPTION:
    ##   Depends/Suggests/Imports/Enhances, Namespace, Priority.
    ## These must be correct if present.

    val <- db[match(c("Depends", "Suggests", "Imports", "Enhances"),
                    names(db), nomatch = 0L)]
    if(length(val)) {
        depends <- .strip_whitespace(unlist(strsplit(val, ",")))
        bad_dep_entry <- bad_dep_op <- bad_dep_version <- character()
        dep_regexp <-
            paste0("^[[:space:]]*",
                   paste0("(R|", valid_package_name_regexp, ")"),
                   "([[:space:]]*\\(([^) ]+)[[:space:]]+([^) ]+)\\))?",
                   "[[:space:]]*$")
        for(dep in depends) {
            if(!grepl(dep_regexp, dep)) {
                ## Entry does not match the regexp.
                bad_dep_entry <- c(bad_dep_entry, dep)
                next
            }
            if(nzchar(sub(dep_regexp, "\\2", dep))) {
                ## If not just a valid package name ...
                if(!sub(dep_regexp, "\\3", dep) %in%
                   c("<=", ">=", "<", ">", "==", "!="))
                    bad_dep_op <- c(bad_dep_op, dep)
                else if(grepl("^[[:space:]]*R", dep)) {
                    if(!grepl(sprintf("^(r[0-9]+|%s)$",
                                      valid_package_version_regexp),
                              sub(dep_regexp, "\\4", dep)))
                    bad_dep_version <- c(bad_dep_version, dep)
                } else if(!grepl(sprintf("^%s$",
                                         valid_package_version_regexp),
                                 sub(dep_regexp, "\\4", dep)))
                    bad_dep_version <- c(bad_dep_version, dep)
            }
        }
        if(length(c(bad_dep_entry, bad_dep_op, bad_dep_version)))
            out$bad_depends_or_suggests_or_imports <-
                list(bad_dep_entry = bad_dep_entry,
                     bad_dep_op = bad_dep_op,
                     bad_dep_version = bad_dep_version)
    }
    if(strict && !is.na(val <- db["VignetteBuilder"])) {
        depends <- .strip_whitespace(unlist(strsplit(val, ",")))
        if(length(depends) < 1L || !all(grepl("^[[:alnum:].]*$", depends)))
            out$bad_vignettebuilder <- TRUE
    }
    if(!is.na(val <- db["Priority"])
       && !is.na(package_name)
       && (tolower(val) %in% c("base", "recommended", "defunct-base"))
       && !(package_name %in% unlist(standard_package_names)))
        out$bad_priority <- val

    class(out) <- "check_package_description"

    out
}

print.check_package_description <-
function(x, ...)
{
    if(length(x$missing_encoding))
        writeLines(c(gettext("Unknown encoding"), ""))

    if(length(x$fields_with_non_ASCII_tags)) {
        writeLines(gettext("Fields with non-ASCII tags:"))
        .pretty_print(x$fields_with_non_ASCII_tags)
        writeLines(c(gettext("All field tags must be ASCII."), ""))
    }

    if(length(x$fields_with_non_ASCII_values)) {
        writeLines(gettext("Fields with non-ASCII values:"))
        .pretty_print(x$fields_with_non_ASCII_values)
        writeLines(c(gettext("These fields must have ASCII values."), ""))
    }

    s <- .format_check_package_description_authors_at_R_field_results(x)
    if(length(s))
        writeLines(c(s, ""))

##     if(length(x$missing_required_fields)) {
##         writeLines(gettext("Required fields missing or empty:"))
##         .pretty_print(x$missing_required_fields)
##         writeLines("")
##     }

    if(length(x$bad_package))
        writeLines(c(strwrap(x$bad_package), ""))

    if(length(x$bad_version))
        writeLines(c(gettext("Malformed package version."), ""))

    if(length(x$bad_maintainer))
        writeLines(c(gettext("Malformed maintainer field."), ""))

    if(any(as.integer(sapply(x$bad_depends_or_suggests_or_imports, length)) > 0L )) {
        bad <- x$bad_depends_or_suggests_or_imports
        writeLines(gettext("Malformed Depends or Suggests or Imports or Enhances field."))
        if(length(bad$bad_dep_entry)) {
            tmp <- c(gettext("Offending entries:"),
                     paste(" ", bad$bad_dep_entry),
                     strwrap(gettextf("Entries must be names of packages optionally followed by '<=' or '>=', white space, and a valid version number in parentheses.")))
            writeLines(tmp)
        }
        if(length(bad$bad_dep_op)) {
            tmp <- c(gettext("Entries with infeasible comparison operator:"),
                     paste(" ", bad$bad_dep_entry),
                     strwrap(gettextf("Only operators '<=' and '>=' are possible.")))

            writeLines(tmp)
        }
        if(length(bad$bad_dep_version)) {
            tmp <- c(gettext("Entries with infeasible version number:"),
                     paste(" ", bad$bad_dep_version),
                     strwrap(gettextf("Version numbers must be sequences of at least two non-negative integers, separated by single '.' or '-'.")))
            writeLines(tmp)
        }
        writeLines("")
    }
    if(identical(x$bad_vignettebuilder, TRUE)) {
        writeLines(c(gettext("Invalid VignetteBuilder field."),
                     strwrap(gettextf("This field must contain one or more packages (and no version requirement).")),
                     ""))
    }

    if(length(x$bad_priority))
        writeLines(c(gettext("Invalid Priority field."),
                     strwrap(gettextf("Packages with priorities 'base' or 'recommended' or 'defunct-base' must already be known to R.")),
                     ""))

    if(any(as.integer(sapply(x, length)) > 0L))
        writeLines(c(strwrap(gettextf("See the information on DESCRIPTION files in section 'Creating R packages' of the 'Writing R Extensions' manual.")),
                     ""))

    invisible(x)
}

### * .check_package_description2

.check_package_description2 <-
function(dfile)
{
    dfile <- file_path_as_absolute(dfile)
    db <- .read_description(dfile)
    depends <- .get_requires_from_package_db(db, "Depends")
    imports <- .get_requires_from_package_db(db, "Imports")
    suggests <- .get_requires_from_package_db(db, "Suggests")
    enhances <- .get_requires_from_package_db(db, "Enhances")
    allpkgs <- c(depends, imports, suggests, enhances)
    out <- unique(allpkgs[duplicated(allpkgs)])
    links <- missing_incs <- character()
    llinks <-  .get_requires_with_version_from_package_db(db, "LinkingTo")
    have_src <- TRUE # dummy
    if(length(llinks)) {
        ## This is pointless unless there is compilable code
        dir.exists <- function(x) !is.na(isdir <- file.info(x)$isdir) & isdir
        have_src <- dir.exists(file.path(dirname(dfile), "src"))

        ## See if this is installable under 3.0.1:
        ## if so check for versioned specs
        deps <- .split_description(db, verbose = TRUE)$Rdepends2
        status <- 0L
        current <- as.numeric_version("3.0.1")
        for(depends in deps) {
            if(!depends$op %in% c("<=", ">=", "<", ">", "==", "!=")) next
            status <- if(inherits(depends$version, "numeric_version"))
                !do.call(depends$op, list(current, depends$version))
            else {
                ver <- R.version
                if (ver$status %in% c("", "Patched")) FALSE
                else !do.call(depends$op,
                              list(ver[["svn rev"]],
                                   as.numeric(sub("^r", "", depends$version))))
            }
        }
        if(!status) {
            llinks <- llinks[sapply(llinks, length) > 1L]
            if(length(llinks)) links <- sapply(llinks, `[[`, 1L)
        }
        ## and check if we can actually link to these.
        llinks <-  .get_requires_from_package_db(db, "LinkingTo")
        incs <- lapply(llinks, function(x) system.file("include", package = x))
        missing_incs <- as.vector(llinks[!nzchar(incs)])
    }
    out <- list(duplicates = unique(allpkgs[duplicated(allpkgs)]),
                bad_links = links, missing_incs = missing_incs,
                have_src = have_src)
    class(out) <- "check_package_description2"
    out
}

format.check_package_description2 <- function(x, ...)
{
    c(if(length(xx <- x$duplicates)) {
        c(if(length(xx) > 1L)
          "Packages listed in more than one of Depends, Imports, Suggests, Enhances:"
        else
          "Package listed in more than one of Depends, Imports, Suggests, Enhances:",
          paste(c(" ", sQuote(xx)), collapse = " "),
          "A package should be listed in only one of these fields.")
    },
      if(!x$have_src) "'LinkingTo' field is unused: package has no 'src' directory",
      if(length(xx <- x$bad_links)) {
          if(length(xx) > 1L)
              c("Versioned 'LinkingTo' values for",
                paste(c(" ", sQuote(xx)), collapse = " "),
                "are only usable in R >= 3.0.2")
          else
              sprintf("Versioned 'LinkingTo' value for %s is only usable in R >= 3.0.2",
                      sQuote(xx))
      },
      if(x$have_src && length(xx <- x$missing_incs)) {
          if(length(xx) > 1L)
              c("'LinkingTo' for",
                paste(c(" ", sQuote(xx)), collapse = " "),
                "are unused as they have no 'include' directory")
          else
              sprintf("'LinkingTo' for %s is unused as it has no 'include' directory", sQuote(xx))
      })
}

.check_package_description_authors_at_R_field <-
function(aar, strict = FALSE)
{
    out <- list()
    if(is.na(aar)) return(out)
    aar <- tryCatch(utils:::.read_authors_at_R_field(aar),
                    error = identity)
    if(inherits(aar, "error")) {
        out$bad_authors_at_R_field <- conditionMessage(aar)
    } else {
        ## Check whether we can expand to something non-empty.
        s <- tryCatch(utils:::.format_authors_at_R_field_for_author(aar),
                      error = identity)
        if(inherits(s, "error")) {
            out$bad_authors_at_R_field_for_author <-
                conditionMessage(s)
        } else {
            if(s == "")
                out$bad_authors_at_R_field_has_no_author <- TRUE
            else {
                attr(out, "Author") <- s
                if(strict) {
                    ## Specifically check for persons with missing or
                    ## non-standard roles.
                    s <- format(aar[sapply(aar,
                                           utils:::.format_person_for_plain_author_spec)
                                    == ""])
                    if(length(s))
                        out$bad_authors_at_R_field_has_author_without_role <- s
                }
            }
        }
        s <- tryCatch(utils:::.format_authors_at_R_field_for_maintainer(aar),
                      error = identity)
        if(inherits(s, "error")) {
            out$bad_authors_at_R_field_for_maintainer <-
                conditionMessage(s)
        } else {
            if(s == "")
                out$bad_authors_at_R_field_has_no_maintainer <- TRUE
            else
                attr(out, "Maintainer") <- s
        }
    }
    out
}

.format_check_package_description_authors_at_R_field_results <-
function(x)
{
    c(character(),
      if(length(bad <- x[["bad_authors_at_R_field"]])) {
          c(gettext("Malformed Authors@R field:"),
            paste(" ", bad))
      },
      if(length(bad <- x[["bad_authors_at_R_field_for_author"]])) {
          c(gettext("Cannot extract Author field from Authors@R field:"),
            paste(" ", bad))
      },
      if(length(x[["bad_authors_at_R_field_has_no_author"]])) {
          gettext("Authors@R field gives no person with author role.")
      },
      if(length(bad <-
                x[["bad_authors_at_R_field_has_author_without_role"]])) {
          c(gettext("Authors@R field gives persons with no valid roles:"),
            paste(" ", bad))
      },
      if(length(bad <- x[["bad_authors_at_R_field_for_maintainer"]])) {
          c(gettext("Cannot extract Maintainer field from Authors@R field:"),
            paste(" ", bad))
      },
      if(length(x[["bad_authors_at_R_field_has_no_maintainer"]])) {
          gettext("Authors@R field gives no person with maintainer role and email address.")
      }
      )
}

### * .check_package_description_encoding

.check_package_description_encoding <-
function(dfile)
{
    dfile <- file_path_as_absolute(dfile)
    db <- .read_description(dfile)
    out <- list()

    ## Check encoding-related things.

    ## All field tags must be ASCII.
    if(any(ind <- !.is_ASCII(names(db))))
        out$fields_with_non_ASCII_tags <- names(db)[ind]

    if(! "Encoding" %in% names(db)) {
        ind <- !.is_ASCII(db)
        if(any(ind)) {
            out$missing_encoding <- TRUE
            out$fields_with_non_ASCII_values <- names(db)[ind]
        }
    } else {
        enc <- db[["Encoding"]]
        if (! enc %in% c("latin1", "latin2", "UTF-8"))
            out$non_portable_encoding <- enc
    }

    class(out) <- "check_package_description_encoding"
    out
}

format.check_package_description_encoding <-
function(x, ...)
{
    c(character(),
      if(length(x$non_portable_encoding)) {
          c(gettextf("Encoding '%s' is not portable",
                     x$non_portable_encoding),
            "")
      },
      if(length(x$missing_encoding)) {
          gettext("Unknown encoding with non-ASCII data")
      },
      if(length(x$fields_with_non_ASCII_tags)) {
          c(gettext("Fields with non-ASCII tags:"),
            .pretty_format(x$fields_with_non_ASCII_tags),
            gettext("All field tags must be ASCII."),
            "")
      },
      if(length(x$fields_with_non_ASCII_values)) {
          c(gettext("Fields with non-ASCII values:"),
            .pretty_format(x$fields_with_non_ASCII_values))
      },
      if(any(as.integer(sapply(x, length)) > 0L)) {
          c(strwrap(gettextf("See the information on DESCRIPTION files in section 'Creating R packages' of the 'Writing R Extensions' manual.")),
            "")
      })
}

### * .check_package_license

.check_package_license <-
function(dfile, dir)
{
    dfile <- file_path_as_absolute(dfile)
    db <- .read_description(dfile)

    if(missing(dir))
        dir <- dirname(dfile)

    ## Analyze the license information here.
    ## Cannot easily do this in .check_package_description(), as R CMD
    ## check's R::Utils::check_package_description() takes any output
    ## from this as indication of an error.

    out <- list()
    if(!is.na(val <- db["License"])) {
        ## If there is no License field, .check_package_description()
        ## will give an error.
        status <- analyze_license(val)
        ok <- status$is_canonical
        ## This analyzes the license specification but does not verify
        ## whether pointers exist, so let us do this here.
        if(length(pointers <- status$pointers)) {
            bad_pointers <-
                pointers[!file_test("-f", file.path(dir, pointers))]
            if(length(bad_pointers)) {
                status$bad_pointers <- bad_pointers
                ok <- FALSE
            }
        }
        depr <- c("Modified BSD License", "BSD")
        if(any(status$components %in% depr)) {
            status$deprecated <- intersect(status$components, depr)
            ok <- FALSE
        }
        ## Components with extensions but not extensible:
        if(length(extensions <- status$extensions) &&
           any(ind <- !extensions$extensible)) {
            status$bad_extensions <- extensions$components[ind]
            ok <- FALSE
        }
        ## Components which need extensions (note that such components
        ## could use the name or abbrev from the license db):
        if(any(ind <- status$components %in%
               c("MIT License", "MIT",
                 "BSD 2-clause License", "BSD_2_clause",
                 "BSD 3-clause License", "BSD_3_clause"))) {
            status$miss_extension <- status$components[ind]
            ok <- FALSE
        }
        ## Could always return the analysis results and not print them
        ## if ok, but it seems more standard to only return trouble.
        if(!ok)
            out <- c(list(license = val), status)
    }

    class(out) <- "check_package_license"
    out
}

format.check_package_license <-
function(x, ...)
{
    if(!length(x))
        return(character())

    check <- Sys.getenv("_R_CHECK_LICENSE_")
    check <- if(check %in% c("maybe", ""))
        (!(x$is_standardizable)
         || length(x$bad_pointers)
         || length(x$bad_extensions))
    else
        isTRUE(as.logical(check))
    if(!check)
        return(character())

    c(character(),
      if(!(x$is_canonical)) {
          c(gettext("Non-standard license specification:"),
            strwrap(x$license, indent = 2L, exdent = 2L),
            gettextf("Standardizable: %s", x$is_standardizable),
            if(x$is_standardizable) {
                c(gettext("Standardized license specification:"),
                  strwrap(x$standardization, indent = 2L, exdent = 2L))
            })
      },
      if(length(y <- x$deprecated)) {
          c(gettextf("Deprecated license: %s",
                     paste(y, collapse = " ")))
      },
      if(length(y <- x$bad_pointers)) {
          c(gettextf("Invalid license file pointers: %s",
                     paste(y, collapse = " ")))
      },
      if(length(y <- x$bad_extensions)) {
          c(gettext("License components with restrictions not permitted:"),
            paste(" ", y))
      },
      if(length(y <- x$miss_extension)) {
          c(gettext("License components which are templates and need '+ file LICENSE':"),
            paste(" ", y))
      }
      )
}

### * .check_make_vars

.check_make_vars <-
function(dir, makevars = c("Makevars.in", "Makevars"))
{
    bad_flags <- list()
    class(bad_flags) <- "check_make_vars"

    paths <- file.path(dir, makevars)
    paths <- paths[file_test("-f", paths)]
    if(!length(paths)) return(bad_flags)
    bad_flags$paths <- file.path("src", basename(paths))
    ## Makevars could be used with --no-configure
    ## and maybe configure does not even use src/Makevars.in
    mfile <- paths[1L]
    make <- Sys.getenv("MAKE")
    if(make == "") make <- "make"
    command <- sprintf("%s -f %s -f %s -f %s",
                       make,
                       shQuote(file.path(R.home("share"), "make",
                                         "check_vars_ini.mk")),
                       shQuote(mfile),
                       shQuote(file.path(R.home("share"), "make",
                                         "check_vars_out.mk")))
    lines <- suppressWarnings(tryCatch(system(command, intern = TRUE,
                                              ignore.stderr = TRUE),
                                       error = identity))
    if(!length(lines) || inherits(lines, "error"))
        return(bad_flags)

    prefixes <- c("CPP", "C", "CXX", "F", "FC", "OBJC", "OBJCXX")

    uflags_re <- sprintf("^(%s)FLAGS: *(.*)$",
                         paste(prefixes, collapse = "|"))
    pos <- grep(uflags_re, lines)
    ind <- (sub(uflags_re, "\\2", lines[pos]) != "-o /dev/null")
    if(any(ind))
        bad_flags$uflags <- lines[pos[ind]]

    ## Try to be careful ...
    pflags_re <- sprintf("^PKG_(%s)FLAGS: ",
                         paste(prefixes, collapse = "|"))
    lines <- lines[grepl(pflags_re, lines)]
    names <- sub(":.*", "", lines)
    lines <- sub(pflags_re, "", lines)
    flags <- strsplit(lines, "[[:space:]]+")
    ## Bad flags:
    ##   -O*
    ##      (BDR: for example Sun Fortran compilers used to accept -O
    ##      but not -O2, and VC++ accepts -Ox (literal x) but not -O.)
    ##   -Wall -pedantic -ansi -traditional -std* -f* -m* [GCC]
    ##   -x [Solaris]
    ##   -q [AIX]
    ## It is hard to think of anything apart from -I* and -D* that is
    ## safe for general use ...
    bad_flags_regexp <-
        sprintf("^-(%s)$",
                paste(c("O.*",
                        "W",
                        "W[^l].*", # -Wl, might just be portable
                        "ansi", "pedantic", "traditional",
                        "f.*", "m.*", "std.*",
                        "x",
                        "q"),
                      collapse = "|"))
    for(i in seq_along(lines)) {
        bad <- grep(bad_flags_regexp, flags[[i]], value = TRUE)
        if(length(bad))
            bad_flags$pflags <-
                c(bad_flags$pflags,
                  structure(list(bad), names = names[i]))
    }

    bad_flags
}

format.check_make_vars <-
function(x, ...)
{
    .fmt <- function(x) {
        s <- Map(c,
                 gettextf("Non-portable flags in variable '%s':",
                          names(x)),
                 sprintf("  %s", lapply(x, paste, collapse = " ")))
        as.character(unlist(s))
    }

    c(character(),
      if(length(bad <- x$pflags)) .fmt(bad),
      if(length(bad <- x$uflags)) {
          c(gettextf("Variables overriding user/site settings:"),
            sprintf("  %s", bad))
      },
      if(length(x$paths) > 1L) {
          c(sprintf("Package has both %s and %s.",
                  sQuote("src/Makevars.in"), sQuote("src/Makevars")),
            strwrap(sprintf("Installation with --no-configure' is unlikely to work.  If you intended %s to be used on Windows, rename it to %s otherwise remove it.  If %s created %s, you need a %s script.",
                            sQuote("src/Makevars"),
                            sQuote("src/Makevars.win"),
                            sQuote("configure"),
                            sQuote("src/Makevars"),
                            sQuote("cleanup"))))
      })
}

### * .check_code_usage_in_package

.check_code_usage_in_package <-
function(package, lib.loc = NULL)
{
    is_base <- package == "base"
    if(!is_base) {
        .load_package_quietly(package, lib.loc)

        .eval_with_capture({
            ## avoid warnings about code in other packages the package
            ## uses
            desc <- readRDS(file.path(find.package(package, NULL),
                                       "Meta", "package.rds"))
            pkgs1 <- sapply(desc$Suggests, "[[", "name")
            pkgs2 <- sapply(desc$Enhances, "[[", "name")
            for(pkg in unique(c(pkgs1, pkgs2)))
                ## tcltk warns if no DISPLAY variable
		##, errors if not compiled in
                suppressWarnings(suppressMessages(try(require(pkg,
                                                              character.only = TRUE,
                                                              quietly = TRUE),
                                                      silent = TRUE)))
        }, type = "output")

        runif(1) # create .Random.seed
        compat <- new.env(hash=TRUE)
        if(.Platform$OS.type != "unix") {
            assign("nsl", function(hostname) {}, envir = compat)
            assign("X11Font", function(font) {}, envir = compat)
            assign("X11Fonts", function(...) {}, envir = compat)
            assign("X11.options", function(..., reset = TRUE) {},
                   envir = compat)
            assign("quartz",
                   function(title, width, height, pointsize, family,
                            fontsmooth, antialias, type, file = NULL,
                            bg, canvas, dpi) {},
                   envir = compat)
            assign("quartzFont", function(family) {}, envir = compat)
            assign("quartzFonts", function(...) {}, envir = compat)
            assign("quartz.options", function(..., reset = TRUE) {},
                   envir = compat)
        }
        if(.Platform$OS.type != "windows") {
            assign("bringToTop", function (which = dev.cur(), stay = FALSE) {},
                   envir = compat)
            assign("choose.dir",
                   function (default = "", caption = "Select folder") {},
                   envir = compat)
            assign("choose.files",
                   function (default = "", caption = "Select files",
                             multi = TRUE, filters = Filters,
                             index = nrow(Filters)) {Filters=NULL}, envir = compat)
            assign("DLL.version", function(path) {}, envir = compat)
            assign("getClipboardFormats", function(numeric = FALSE) {},
                   envir = compat)
            assign("getIdentification", function() {}, envir = compat)
            assign("getWindowsHandle", function(which = "Console") {},
                   envir = compat)
            assign("getWindowTitle", function() {}, envir = compat)
            assign("readClipboard", function(format = 1, raw = FALSE) {},
                   envir = compat)
            assign("setWindowTitle",
                   function(suffix, title = paste(getIdentification(), suffix)) {},
                   envir = compat)
            assign("shell",
                   function(cmd, shell, flag = "/c", intern = FALSE,
                            wait = TRUE, translate = FALSE, mustWork = FALSE,
                            ...) {},
                   envir = compat)
            assign("shell.exec", function(file) {}, envir = compat)
            assign("shortPathName", function(path) {}, envir = compat)
            assign("win.version", function() {}, envir = compat)
            assign("zip.unpack", function(zipname, dest) {}, envir = compat)
            assign("savePlot",
                   function (filename = "Rplot",
                             type = c("wmf", "emf", "png", "jpeg", "jpg",
                                      "bmp", "ps", "eps", "pdf"),
                             device = dev.cur(), restoreConsole = TRUE) {},
                   envir = compat)
            assign("win.graph",
                   function(width = 7, height = 7, pointsize = 12,
                            restoreConsole = FALSE) {}, envir = compat)
            assign("win.metafile",
                   function (filename = "", width = 7, height = 7,
                             pointsize = 12, family = "",
                             restoreConsole = TRUE) {},
                   envir = compat)
            assign("win.print",
                   function(width = 7, height = 7, pointsize = 12,
                            printer = "", family = "", antialias = "default",
                            restoreConsole = TRUE) {},
                   envir = compat)
            assign("windows",
                   function(width, height, pointsize,
                            record, rescale, xpinch, ypinch,
                            bg, canvas, gamma, xpos, ypos,
                            buffered, title, restoreConsole, clickToConfirm,
                            fillOddEven, family = "", antialias) {},
                            envir = compat)
            assign("windowsFont", function(font) {}, envir = compat)
            assign("windowsFonts", function(...) {}, envir = compat)
            assign("windows.options", function(..., reset = TRUE) {},
                   envir = compat)

            assign("winDialog", function(type = "ok", message) {},
                   envir = compat)
            assign("winDialogString", function(message, default) {},
                   envir = compat)
            assign("winMenuAdd", function(menuname) {}, envir = compat)
            assign("winMenuAddItem", function(menuname, itemname, action) {},
                   envir = compat)
            assign("winMenuDel", function(menuname) {}, envir = compat)
            assign("winMenuDelItem", function(menuname, itemname) {},
                   envir = compat)
            assign("winMenuNames", function() {}, envir = compat)
            assign("winMenuItems", function(menuname) {}, envir = compat)
            assign("winProgressBar",
                   function(title = "R progress bar", label = "",
                            min = 0, max = 1, initial = 0, width = 300) {},
                   envir = compat)
            assign("setWinProgressBar",
                   function(pb, value, title=NULL, label=NULL) {},
                   envir = compat)
            assign(".install.winbinary",
                   function(pkgs, lib, repos = getOption("repos"),
                            contriburl = contrib.url(repos),
                            method, available = NULL, destdir = NULL,
                            dependencies = FALSE, libs_only = FALSE,
                            ...) {}, envir = compat)
            assign("Sys.junction", function(from, to) {}, envir = compat)
        }
        attach(compat, name="compat", pos = length(search()),
               warn.conflicts = FALSE)
    }

    ## A simple function for catching the output from the codetools
    ## analysis using the checkUsage report mechanism.
    out <- character()
    foo <- function(x) out <<- c(out, x)
    ## (Simpler than using a variant of capture.output().)
    ## Of course, it would be nice to return a suitably structured
    ## result, but we can always do this by suitably splitting the
    ## messages on the double colons ...

    ## Not only check function definitions, but also S4 methods
    ## [a version of this should be part of codetools eventually] :
    checkMethodUsageEnv <- function(env, ...) {
	for(g in .get_S4_generics(env))
	    for(m in .get_S4_methods_list(g, env)) {
		fun <- methods::getDataPart(m)
		signature <- paste(m@generic,
				   paste(m@target, collapse = "-"),
				   sep = ",")
		codetools::checkUsage(fun, signature, ...)
	    }
    }
    checkMethodUsagePackage <- function (pack, ...) {
	pname <- paste("package", pack, sep = ":")
	if (!pname %in% search())
	    stop("package must be loaded", domain = NA)
	checkMethodUsageEnv(if (pack %in% loadedNamespaces())
			    getNamespace(pack) else as.environment(pname), ...)
    }

    ## Allow specifying a codetools "profile" for checking via the
    ## environment variable _R_CHECK_CODETOOLS_PROFILE_, used as e.g.
    ##   _R_CHECK_CODETOOLS_PROFILE_="suppressLocalUnused=FALSE"
    ## (where the values get converted to logicals "the usual way").
    args <- list(skipWith = TRUE,
                 suppressPartialMatchArgs = FALSE,
                 suppressLocalUnused = TRUE)
    opts <- unlist(strsplit(Sys.getenv("_R_CHECK_CODETOOLS_PROFILE_"),
                            "[[:space:]]*,[[:space:]]*"))
    if(length(opts)) {
        args[sub("[[:space:]]*=.*", "", opts)] <-
            lapply(sub(".*=[[:space:]]*", "", opts),
                   config_val_to_logical)
    }
    ## look for globalVariables declaration in package
    .glbs <- utils::globalVariables(,package)
    if(length(.glbs))
        ## codetools doesn't allow adding to its default
        args$suppressUndefined <-
            c(codetools:::dfltSuppressUndefined, .glbs)

    args <- c(list(package, report = foo), args)
    suppressMessages(do.call(codetools::checkUsagePackage, args))
    suppressMessages(do.call(checkMethodUsagePackage, args))

    out <- unique(out)
    class(out) <- "check_code_usage_in_package"
    out
}

format.check_code_usage_in_package <-
function(x, ...)
{
    if(length(x)) {
        ## There seems no easy we can gather usage diagnostics by type,
        ## so try to rearrange to some extent when formatting.
        ind <- grepl(": partial argument match of", x, fixed = TRUE)
        if(any(ind)) x <- c(x[ind], x[!ind])
    }
    strwrap(x, indent = 0L, exdent = 2L)
}

### * .check_Rd_xrefs

.check_Rd_xrefs <-
function(package, dir, lib.loc = NULL)
{
    ## Build a db with all possible link targets (aliases) in the base
    ## and recommended packages.
    base <- unlist(.get_standard_package_names()[c("base", "recommended")],
                   use.names = FALSE)
    aliases <- lapply(base, Rd_aliases, lib.loc = NULL)
    ## (Don't use lib.loc = .Library, as recommended packages may have
    ## been installed to a different place.)

    ## Now find the aliases in packages it depends on
    if(!missing(package)) {
        pfile <- system.file("Meta", "package.rds", package = package,
                             lib.loc = lib.loc)
        pkgInfo <- readRDS(pfile)
    } else {
        outDir <- file.path(tempdir(), "fake_pkg")
        dir.create(file.path(outDir, "Meta"), FALSE, TRUE)
        .install_package_description(dir, outDir)
        pfile <- file.path(outDir, "Meta", "package.rds")
        pkgInfo <- readRDS(pfile)
        unlink(outDir, recursive = TRUE)
    }
    ## only 'Depends' are guaranteed to be on the search path, but
    ## 'Imports' have to be installed and hence help there will be found
    deps <- c(names(pkgInfo$Depends), names(pkgInfo$Imports))
    pkgs <- setdiff(unique(deps), base)
    try_Rd_aliases <- function(...) tryCatch(Rd_aliases(...), error = identity)
    aliases <- c(aliases, lapply(pkgs, try_Rd_aliases, lib.loc = lib.loc))
    aliases[sapply(aliases, class) == "error"] <- NULL

    ## Add the aliases from the package itself, and build a db with all
    ## (if any) \link xrefs in the package Rd objects.
    if(!missing(package)) {
        aliases1 <- Rd_aliases(package, lib.loc = lib.loc)
        if(!length(aliases1))
            return(structure(NULL, class = "check_Rd_xrefs"))
        aliases <- c(aliases, list(aliases1))
        db <- .build_Rd_xref_db(package, lib.loc = lib.loc)
    } else {
        aliases1 <- Rd_aliases(dir = dir)
        if(!length(aliases1))
            return(structure(NULL, class = "check_Rd_xrefs"))
        aliases <- c(aliases, list(aliases1))
        db <- .build_Rd_xref_db(dir = dir)
    }

    ## Flatten the xref db into one big matrix.
    db <- cbind(do.call("rbind", db), rep(names(db), sapply(db, NROW)))
    if(nrow(db) == 0L) return(structure(NULL, class = "check_Rd_xrefs"))

    ## fixup \link[=dest] form
    anchor <- db[, 2L]
    have_equals <- grepl("^=", anchor)
    if(any(have_equals))
        db[have_equals, 1:2] <- cbind(sub("^=", "", anchor[have_equals]), "")

    db <- cbind(db, bad = FALSE, report = db[, 1L])
    have_anchor <- nzchar(anchor <- db[, 2L])
    db[have_anchor, "report"] <-
        paste0("[", db[have_anchor, 2L], "]{", db[have_anchor, 1L], "}")

    ## Check the targets from the non-anchored xrefs.
    db[!have_anchor, "bad"] <- !( db[!have_anchor, 1L] %in% unlist(aliases))

    ## and then check the anchored ones if we can.
    have_colon <- grepl(":", anchor, fixed = TRUE)
    unknown <- character()
    thispkg <- anchor
    thisfile <- db[, 1L]
    thispkg [have_colon] <- sub("([^:]*):(.*)", "\\1", anchor[have_colon])
    thisfile[have_colon] <- sub("([^:]*):(.*)", "\\2", anchor[have_colon])

    use_aliases_from_CRAN <-
        config_val_to_logical(Sys.getenv("_R_CHECK_XREFS_USE_ALIASES_FROM_CRAN_",
                                         FALSE))
    if(use_aliases_from_CRAN) {
        CRAN <- .get_standard_repository_URLs()[1L]
        CRAN_aliases_db <- NULL
    }

    for (pkg in unique(thispkg[have_anchor])) {
        ## we can't do this on the current uninstalled package!
        if (missing(package) && pkg == basename(dir)) next
        this <- have_anchor & (thispkg %in% pkg)
        top <- system.file(package = pkg, lib.loc = lib.loc)
        if(nzchar(top)) {
            RdDB <- file.path(top, "help", "paths.rds")
            if(!file.exists(RdDB)) {
                message(gettextf("package %s exists but was not installed under R >= 2.10.0 so xrefs cannot be checked", sQuote(pkg)),
                        domain = NA)
                next
            }
            nm <- sub("\\.[Rr]d", "", basename(readRDS(RdDB)))
            good <- thisfile[this] %in% nm
            suspect <- if(any(!good)) {
                aliases1 <- if (pkg %in% names(aliases)) aliases[[pkg]]
                else Rd_aliases(pkg, lib.loc = lib.loc)
                !good & (thisfile[this] %in% aliases1)
            } else FALSE
            db[this, "bad"] <- !good & !suspect
        } else if(use_aliases_from_CRAN) {
            if(is.null(CRAN_aliases_db)) {
                ## Not yet read in.
                ## message("Reading in aliases db ...")
                con <- gzcon(url(sprintf("%s/src/contrib/Meta/aliases.rds",
                                         CRAN),
                                 "rb"))
                CRAN_aliases_db <- readRDS(con)
                close(con)
            }
            aliases <- CRAN_aliases_db[[pkg]]
            if(is.null(aliases)) {
                unknown <- c(unknown, pkg)
                next
            }
            ## message(sprintf("Using aliases db for package %s", pkg))
            nm <- sub("\\.[Rr]d", "", basename(names(aliases)))
            good <- thisfile[this] %in% nm
            suspect <- if(any(!good)) {
                aliases1 <- unique(as.character(unlist(aliases,
                                                       use.names =
                                                       FALSE)))
                !good & (thisfile[this] %in% aliases1)
            } else FALSE
        }
        else
            unknown <- c(unknown, pkg)
    }

    unknown <- unique(unknown)
    obsolete <- unknown %in% c("ctest", "eda", "lqs", "mle", "modreg", "mva", "nls", "stepfun", "ts")
    if (any(obsolete)) {
        message(sprintf(ngettext(sum(obsolete),
                                 "Obsolete package %s in Rd xrefs",
                                 "Obsolete packages %s in Rd xrefs"),
                        paste(sQuote(unknown[obsolete]), collapse = ", ")),
                domain = NA)
    }
    unknown <- unknown[!obsolete]
    if (length(unknown)) {
        repos <- .get_standard_repository_URLs()
        known <-
            try(suppressWarnings(utils::available.packages(utils::contrib.url(repos, "source"),
               filters = c("R_version", "duplicates"))[, "Package"]))
        miss <- if(inherits(known, "try-error")) TRUE
        else unknown %in% c(known, c("GLMMGibbs", "survnnet", "yags"))
        ## from CRANextras
        if(any(miss))
            message(sprintf(ngettext(sum(miss),
                                     "Package unavailable to check Rd xrefs: %s",
                                     "Packages unavailable to check Rd xrefs: %s"),
                             paste(sQuote(unknown[miss]), collapse = ", ")),
                    domain = NA)
        if(any(!miss))
            message(sprintf(ngettext(sum(!miss),
                                     "Unknown package %s in Rd xrefs",
                                     "Unknown packages %s in Rd xrefs"),
                             paste(sQuote(unknown[!miss]), collapse = ", ")),
                    domain = NA)
    }
    ## The bad ones:
    bad <- db[, "bad"] == "TRUE"
    res1 <- split(db[bad, "report"], db[bad, 3L])
    structure(list(bad = res1), class = "check_Rd_xrefs")
}

format.check_Rd_xrefs <-
function(x, ...)
{
    xx <- x$bad
    if(length(xx)) {
        .fmt <- function(i) {
            c(gettextf("Missing link or links in documentation object '%s':",
                       names(xx)[i]),
              ## NB, link might be empty, and was in mvbutils
              .pretty_format(unique(xx[[i]])),
              "")
        }
        c(unlist(lapply(seq_along(xx), .fmt)),
          strwrap(gettextf("See the information in section 'Cross-references' of the 'Writing R Extensions' manual.")),
          "")
    } else {
        character()
    }
}

### * .check_package_datasets

.check_package_datasets <-
function(pkgDir)
{
    Sys.setlocale("LC_CTYPE", "C")
    options(warn=-1)
    check_one <- function(x, ds)
    {
        if(!length(x)) return()
        ## avoid as.list methods
        if(is.list(x)) lapply(unclass(x), check_one, ds = ds)
        if(is.character(x)) {
            xx <- unclass(x)
            enc <- Encoding(xx)
            latin1 <<- latin1 + sum(enc == "latin1")
            utf8 <<- utf8 + sum(enc == "UTF-8")
            bytes <<- bytes + sum(enc == "bytes")
            unk <- xx[enc == "unknown"]
            ind <- .Call(check_nonASCII2, unk)
            if(length(ind)) {
                non_ASCII <<- c(non_ASCII, unk[ind])
                where <<- c(where, rep.int(ds, length(ind)))
            }
        }
        a <- attributes(x)
        if(!is.null(a)) {
            lapply(a, check_one, ds = ds)
            check_one(names(a), ds)
        }
        invisible()
    }

    sink(tempfile()) ## suppress startup messages to stdout
    on.exit(sink())
    files <- list_files_with_type(file.path(pkgDir, "data"), "data")
    files <- unique(basename(file_path_sans_ext(files)))
    ans <- vector("list", length(files))
    dataEnv <- new.env(hash=TRUE)
    names(ans) <- files
    old <- setwd(pkgDir)
    for(f in files)
        .try_quietly(utils::data(list = f, package = character(),
                                 envir = dataEnv))
    setwd(old)

    non_ASCII <- where <- character()
    latin1 <- utf8 <- bytes <- 0L
    ## avoid messages about loading packages that started with r48409
    suppressPackageStartupMessages({
        for(ds in ls(envir = dataEnv, all.names = TRUE))
            check_one(get(ds, envir = dataEnv), ds)
    })
    unknown <- unique(cbind(non_ASCII, where))
    structure(list(latin1 = latin1, utf8 = utf8, bytes = bytes,
                   unknown = unknown),
              class = "check_package_datasets")
}

format.check_package_datasets <-
function(x, ...)
{
    ## not sQuote as we have mucked about with locales.
    iconv0 <- function(x, ...) paste0("'", iconv(x, ...), "'")

    c(character(),
      if(n <- x$latin1) {
          sprintf(
                  ngettext(n,
                   "Note: found %d marked Latin-1 string",
                   "Note: found %d marked Latin-1 strings"), n)
      },
      if(n <- x$utf8) {
          sprintf(
                  ngettext(n,
                           "Note: found %d marked UTF-8 string",
                           "Note: found %d marked UTF-8 strings"), n)
      },
      if(n <- x$bytes) {
          sprintf(
                  ngettext(n,
                           "Note: found %d string marked as \"bytes\"",
                           "Note: found %d strings marked as \"bytes\""), n)
      },
      if(nr <- nrow(x$unknown)) {
          msg <- ngettext(nr,
                          "Warning: found non-ASCII string",
                          "Warning: found non-ASCII strings",
                          domain = NA)
          c(msg,
            paste0(iconv0(x$unknown[, 1L], "", "ASCII", sub = "byte"),
                   " in object '", x$unknown[, 2L], "'"))
      })
}

### * .check_package_datasets

.check_package_compact_datasets <-
function(pkgDir, thorough = FALSE)
{
    msg <- NULL
    rdas <- checkRdaFiles(file.path(pkgDir, "data"))
    row.names(rdas) <- basename(row.names(rdas))
    problems <- with(rdas, (ASCII | compress == "none") & (size > 1e5))
    if (any(rdas$compress %in% c("bzip2", "xz"))) {
        OK <- FALSE
        Rdeps <- .split_description(.read_description(file.path(pkgDir, "DESCRIPTION")))$Rdepends2
        for(dep in Rdeps) {
            if(dep$op != '>=') next
            if(dep$version >= package_version("2.10")) {OK <- TRUE; break;}
        }
        if(!OK) msg <- "Warning: package needs dependence on R (>= 2.10)"
    }
    if (sum(rdas$size) < 1e5 || # we don't report unless we get a 1e5 reduction
        any(rdas$compress %in% c("bzip2", "xz"))) # assume already optimized
        thorough <- FALSE
    sizes <- improve <- NULL
    if (thorough) {
        files <- Sys.glob(c(file.path(pkgDir, "data", "*.rda"),
                            file.path(pkgDir, "data", "*.RData")))
        ## Exclude .RData, which this may or may not match
        files <- grep("/[.]RData$", files, value = TRUE, invert = TRUE)
        if (length(files)) {
            cpdir <- tempfile('cp')
            dir.create(cpdir)
            file.copy(files, cpdir)
            resaveRdaFiles(cpdir)
            rdas2 <- checkRdaFiles(cpdir)
            row.names(rdas2) <- basename(row.names(rdas2))
            diff2 <- (rdas2$ASCII != rdas$ASCII) | (rdas2$compress != rdas$compress)
            diff2 <- diff2 & (rdas$size > 1e4) & (rdas2$size < 0.9*rdas$size)
            sizes <- c(sum(rdas$size), sum(rdas2$size))
            improve <- data.frame(old_size = rdas$size,
                                  new_size = rdas2$size,
                                  compress = rdas2$compress,
                                  row.names = row.names(rdas))[diff2, ]
        }
    }
    structure(list(rdas = rdas[problems, 1:3], msg = msg,
                   sizes = sizes, improve = improve),
              class = "check_package_compact_datasets")
}

print.check_package_compact_datasets <-
function(x, ...)
{
    reformat <- function(x) {
        xx <- paste0(x, "b")
        ind1 <- (x >= 1024)
        xx[ind1] <- sprintf("%.0fKb", x[ind1]/1024)
        ind2 <- x >= 1024^2
        xx[ind2] <- sprintf("%.1fMb", x[ind2]/(1024^2))
        ind3 <- x >= 1024^3
        xx[ind3] <- sprintf("%.1fGb", x[ind3]/1024^3)
        xx
    }
    if(nr <- nrow(x$rdas)) {
        msg <- ngettext(nr,
                        "Warning: large data file saved inefficiently:",
                        "Warning: large data files saved inefficiently:",
                        domain = NA)
        writeLines(msg)
        rdas <- x$rdas
        rdas$size <- reformat(rdas$size)
        print(rdas)
    }
    if(!is.null(x$msg)) writeLines(x$msg)
    if(!is.null(s <- x$sizes) && s[1L] - s[2L] > 1e5  # save at least 100Kb
       && s[2L]/s[1L] < 0.9) { # and at least 10%
        writeLines(c("",
                     "Note: significantly better compression could be obtained",
                     "      by using R CMD build --resave-data"))
        if(nrow(x$improve)) {
            improve <- x$improve
            improve$old_size <- reformat(improve$old_size)
            improve$new_size <- reformat(improve$new_size)
            print(improve)
        }
    }
    invisible(x)
}

.check_package_compact_sysdata <-
function(pkgDir, thorough = FALSE)
{
    msg <- NULL
    files <- file.path(pkgDir, "R", "sysdata.rda")
    rdas <- checkRdaFiles(files)
    row.names(rdas) <- basename(row.names(rdas))
    problems <- with(rdas, (ASCII | compress == "none") & (size > 1e5))
    if (any(rdas$compress %in% c("bzip2", "xz"))) {
        OK <- FALSE
        Rdeps <- .split_description(.read_description(file.path(pkgDir, "DESCRIPTION")))$Rdepends2
        for(dep in Rdeps) {
            if(dep$op != '>=') next
            if(dep$version >= package_version("2.10")) {OK <- TRUE; break;}
        }
        if(!OK) msg <- "Warning: package needs dependence on R (>= 2.10)"
    }
    if (sum(rdas$size) < 1e5 || # we don't report unless we get a 1e5 reduction
        any(rdas$compress %in% c("bzip2", "xz"))) # assume already optimized
        thorough <- FALSE
    if (thorough) {
        cpdir <- tempfile('cp')
        dir.create(cpdir)
        file.copy(files, cpdir)
        resaveRdaFiles(cpdir)
        rdas2 <- checkRdaFiles(cpdir)
        row.names(rdas2) <- basename(row.names(rdas2))
        diff2 <- (rdas2$ASCII != rdas$ASCII) | (rdas2$compress != rdas$compress)
        diff2 <- diff2 & (rdas$size > 1e4) & (rdas2$size < 0.9*rdas$size)
        sizes <- c(sum(rdas$size), sum(rdas2$size))
        improve <- data.frame(old_size = rdas$size,
                              new_size = rdas2$size,
                              compress = rdas2$compress,
                              row.names = row.names(rdas))[diff2, ]
    } else sizes <- improve <- NULL
    structure(list(rdas = rdas[problems, 1:3], msg = msg,
                   sizes = sizes, improve = improve),
              class = "check_package_compact_datasets")
}


### * .check_package_subdirs

## used by R CMD build
.check_package_subdirs <-
function(dir, doDelete = FALSE)
{
    OS_subdirs <- c("unix", "windows")

    mydir <- function(dir)
    {
        d <- list.files(dir, all.files = TRUE, full.names = FALSE)
        if(!length(d)) return(d)
        if(basename(dir) %in% c("R", "man"))
            for(os in OS_subdirs) {
                os_dir <- file.path(dir, os)
                if(file_test("-d", os_dir))
                    d <- c(d,
                           file.path(os,
                                     list.files(os_dir,
                                                all.files = TRUE,
                                                full.names = FALSE)))
            }
        d[file_test("-f", file.path(dir, d))]
    }

    if(!file_test("-d", dir))
        stop(gettextf("directory '%s' does not exist", dir), domain = NA)
    else
        dir <- file_path_as_absolute(dir)

    wrong_things <- list(R = character(), man = character(),
                         demo = character(), `inst/doc` = character())

    code_dir <- file.path(dir, "R")
    if(file_test("-d", code_dir)) {
        all_files <- mydir(code_dir)
        ## Under Windows, need a Makefile.win for methods.
        R_files <- c("sysdata.rda", "Makefile.win",
                     list_files_with_type(code_dir, "code",
                                          full.names = FALSE,
                                          OS_subdirs = OS_subdirs))
        wrong <- setdiff(all_files, R_files)
        ## now configure might generate files in this directory
        generated <- grep("\\.in$", wrong)
        if(length(generated)) wrong <- wrong[-generated]
        if(length(wrong)) {
            wrong_things$R <- wrong
            if(doDelete) unlink(file.path(dir, "R", wrong))
        }
    }

    man_dir <- file.path(dir, "man")
    if(file_test("-d", man_dir)) {
        all_files <- mydir(man_dir)
        man_files <- list_files_with_type(man_dir, "docs",
                                          full.names = FALSE,
                                          OS_subdirs = OS_subdirs)
        wrong <- setdiff(all_files, man_files)
        if(length(wrong)) {
            wrong_things$man <- wrong
            if(doDelete) unlink(file.path(dir, "man", wrong))
        }
    }

    demo_dir <- file.path(dir, "demo")
    if(file_test("-d", demo_dir)) {
        all_files <- mydir(demo_dir)
        demo_files <- list_files_with_type(demo_dir, "demo",
                                           full.names = FALSE)
        wrong <- setdiff(all_files, c("00Index", demo_files))
        if(length(wrong)) {
            wrong_things$demo <- wrong
            if(doDelete) unlink(file.path(dir, "demo", wrong))
        }
    }

    ## check installed vignette material
    subdir <- file.path("inst", "doc")
    vigns <- pkgVignettes(dir = dir, subdirs = subdir)
    if (!is.null(vigns) && length(vigns$docs)) {
        vignettes <- basename(vigns$docs)

        ## Add vignette output files, if they exist
        tryCatch({
            vigns <- pkgVignettes(dir = dir, subdirs = subdir, output = TRUE)
            vignettes <- c(vignettes, basename(vigns$outputs))
        }, error = function(ex) {})

        ## 'the file names should start with an ASCII letter and be comprised
        ## entirely of ASCII letters or digits or hyphen or underscore'
        ## Do this in a locale-independent way.
        OK <- grep("^[ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz][ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789._-]+$", vignettes)
        wrong <- vignettes
        if(length(OK)) wrong <- wrong[-OK]
        if(length(wrong)) wrong_things$`inst/doc` <- wrong
    }

    class(wrong_things) <- "subdir_tests"
    wrong_things
}

format.subdir_tests <-
function(x, ...)
{
    .fmt <- function(i) {
        tag <- names(x)[i]
        c(sprintf("Subdirectory '%s' contains invalid file names:",
                  tag),
          .pretty_format(x[[i]]))
    }

    as.character(unlist(lapply(which(sapply(x, length) > 0L), .fmt)))
}

### * .check_package_ASCII_code

.check_package_ASCII_code <-
function(dir, respect_quotes = FALSE)
{
    OS_subdirs <- c("unix", "windows")
    if(!file_test("-d", dir))
        stop(gettextf("directory '%s' does not exist", dir), domain = NA)
    else
        dir <- file_path_as_absolute(dir)

    code_dir <- file.path(dir, "R")
    wrong_things <- character()
    if(file_test("-d", code_dir)) {
        R_files <- list_files_with_type(code_dir, "code",
                                        full.names = FALSE,
                                        OS_subdirs = OS_subdirs)
        for(f in R_files) {
            text <- readLines(file.path(code_dir, f), warn = FALSE)
            if(.Call(check_nonASCII, text, !respect_quotes))
                wrong_things <- c(wrong_things, f)
        }
    }
    if(length(wrong_things)) cat(wrong_things, sep = "\n")
    invisible(wrong_things)
}

### * .check_package_code_syntax

.check_package_code_syntax <-
function(dir)
{
    if(!file_test("-d", dir))
        stop(gettextf("directory '%s' does not exist", dir), domain = NA)
    else
        dir <- file_path_as_absolute(dir)
    dir_name <- basename(dir)

    dfile <- file.path(dirname(dir), "DESCRIPTION")
    enc <- if(file.exists(dfile))
        .read_description(dfile)["Encoding"] else NA

    ## This was always run in the C locale < 2.5.0
    ## However, what chars are alphabetic depends on the locale,
    ## so as from R 2.5.0 we try to set a locale.
    ## Any package with no declared encoding should have only ASCII R code.
    if(!is.na(enc)) {  ## try to use the declared encoding
        if(.Platform$OS.type == "windows") {
            ## "C" is in fact "en", and there are no UTF-8 locales
            switch(enc,
                   "latin2" = Sys.setlocale("LC_CTYPE", 'polish'),
                   Sys.setlocale("LC_CTYPE", "C")
                   )
        } else {
            loc <- Sys.getenv("R_ENCODING_LOCALES", NA)
            if(!is.na(loc)) {
                loc <- strsplit(strsplit(loc, ":")[[1L]], "=")
                nm <- lapply(loc, "[[", 1L)
                loc <- lapply(loc, "[[", 2L)
                names(loc) <- nm
                if(!is.null(l <- loc[[enc]]))
                    Sys.setlocale("LC_CTYPE", l)
                else
                    Sys.setlocale("LC_CTYPE", "C")

            } else if(l10n_info()[["UTF-8"]]) {
                ## the hope is that the conversion to UTF-8 works and
                ## so we can validly test the code in the current locale.
            } else {
                ## these are the POSIX forms, but of course not all Unixen
                ## abide by POSIX.  These locales need not exist, but
                ## do in glibc.
                switch(enc,
                       "latin1" = Sys.setlocale("LC_CTYPE", "en_US"),
                       "utf-8"  =,  # not valid, but used
                       "UTF-8"  = Sys.setlocale("LC_CTYPE", "en_US.utf8"),
                       "latin2" = Sys.setlocale("LC_CTYPE", "pl_PL"),
                       "latin9" = Sys.setlocale("LC_CTYPE",
                       "fr_FR.iso885915@euro"),
                       Sys.setlocale("LC_CTYPE", "C")
                      )
            }
        }
    }

    collect_parse_woes <- function(f) {
        .error <- .warnings <- character()
        file <- file.path(dir, f)
        if(!is.na(enc) &&
           !(Sys.getlocale("LC_CTYPE") %in% c("C", "POSIX"))) {
            lines <- iconv(readLines(file, warn = FALSE), from = enc, to = "",
                           sub = "byte")
            withCallingHandlers(tryCatch(parse(text = lines),
                                         error = function(e)
                                         .error <<- conditionMessage(e)),
                                warning = function(e) {
                                    .warnings <<- c(.warnings,
                                                    conditionMessage(e))
                                    invokeRestart("muffleWarning")
                                })
        } else {
            withCallingHandlers(tryCatch(parse(file),
                                         error = function(e)
                                         .error <<- conditionMessage(e)),
                                warning = function(e) {
                                    .warnings <<- c(.warnings,
                                                    conditionMessage(e))
                                    invokeRestart("muffleWarning")
                                })
        }
        ## (We show offending file paths starting with the base of the
        ## given directory as this provides "nicer" output ...)
        if(length(.error) || length(.warnings))
            list(File = file.path(dir_name, f),
                 Error = .error, Warnings = .warnings)
        else
            NULL
    }

    out <-
        lapply(list_files_with_type(dir, "code", full.names = FALSE,
                                    OS_subdirs = c("unix", "windows")),
               collect_parse_woes)
    Sys.setlocale("LC_CTYPE", "C")
    structure(out[sapply(out, length) > 0L],
              class = "check_package_code_syntax")
}

print.check_package_code_syntax <-
function(x, ...)
{
    first <- TRUE
    for(i in seq_along(x)) {
        if(!first) writeLines("") else first <- FALSE
        xi <- x[[i]]
        if(length(xi$Error)) {
            msg <- gsub("\n", "\n  ", sub("[^:]*: *", "", xi$Error),
			perl = TRUE, useBytes = TRUE)
            writeLines(c(sprintf("Error in file '%s':", xi$File),
                         paste(" ", msg)))
        }
        if(len <- length(xi$Warnings))
            writeLines(c(sprintf(ngettext(len,
                                          "Warning in file %s:",
                                          "Warnings in file %s:"),
                                 sQuote(xi$File)),
                         paste(" ", gsub("\n\n", "\n  ", xi$Warnings,
					 perl = TRUE, useBytes = TRUE))))
    }
    invisible(x)
}

### * .check_package_code_shlib

.check_package_code_shlib <-
function(dir)
{
    predicate <- function(e) {
        ((length(e) > 1L)
         && (as.character(e[[1L]]) %in%
             c("library.dynam", "library.dynam.unload"))
         && is.character(e[[2L]])
         && grepl("\\.(so|sl|dll)$", e[[2L]]))
    }

    x <- Filter(length,
                .find_calls_in_package_code(dir, predicate,
                                            recursive = TRUE))

    ## Because we really only need this for calling from R CMD check, we
    ## produce output here in case we found something.
    if(length(x))
        writeLines(c(unlist(Map(.format_calls_in_file, x, names(x))),
                     ""))
    ## (Could easily provide format() and print() methods ...)

    invisible(x)
}

### * .check_package_code_startup_functions

.check_package_code_startup_functions <-
function(dir)
{
    bad_call_names <-
        unlist(.bad_call_names_in_startup_functions)

    .check_startup_function <- function(fcode, fname) {
        out <- list()
        nms <- names(fcode[[2L]])
        ## Check names of formals.
        ## Allow anything containing ... (for now); otherwise, insist on
        ## length two with names starting with lib and pkg, respectively.
        if(is.na(match("...", nms)) &&
           ((length(nms) != 2L) ||
            any(substring(nms, 1L, 3L) != c("lib", "pkg"))))
            out$bad_arg_names <- nms
        ## Look at all calls (not only at top level).
        calls <- .find_calls(fcode[[3L]], recursive = TRUE)
        if(!length(calls)) return(out)
        cnames <- .call_names(calls)
        ## And pick the ones which should not be there ...
        bcn <- bad_call_names
        if(fname == ".onAttach") bcn <- c(bcn, "library.dynam")
        if(fname == ".onLoad") bcn <- c(bcn, "packageStartupMessage")
        ind <- (cnames %in% bcn)
        if(any(ind)) {
            calls <- calls[ind]
            cnames <- cnames[ind]
            ## Exclude library(help = ......) calls.
            pos <- which(cnames == "library")
            if(length(pos)) {
                pos <- pos[sapply(calls[pos],
                                  function(e)
                                  any(names(e)[-1L] == "help"))]
                ## Could also match.call(base::library, e) first ...
                if(length(pos)) {
                    calls <- calls[-pos]
                    cnames <- cnames[-pos]
                }
            }
            if(length(calls)) {
                out$bad_calls <-
                    list(calls = calls, names = cnames)
            }
        }
        out
    }

    calls <- .find_calls_in_package_code(dir,
                                         .worker =
                                         .get_startup_function_calls_in_file)
    FL <- unlist(lapply(calls, "[[", ".First.lib"))
    calls <- Filter(length,
                    lapply(calls,
                           function(e)
                           Filter(length,
                                  Map(.check_startup_function,
                                      e, names(e)))))
    if(length(FL)) attr(calls, ".First.lib") <- TRUE
    class(calls) <- "check_package_code_startup_functions"
    calls
}

format.check_package_code_startup_functions <-
function(x, ...)
{
    res <- if(!is.null(attr(x, ".First.lib"))) "NB: .First.lib is obsolete and will not be used in R >= 3.0.0" else character()
    if(length(x)) {

        ## Flatten out doubly recursive list of functions within list of
        ## files structure for computing summary messages.
        y <- unlist(x, recursive = FALSE)

        has_bad_wrong_args <-
            "bad_arg_names" %in% unlist(lapply(y, names))
        calls <-
            unique(unlist(lapply(y,
                                 function(e) e[["bad_calls"]][["names"]])))
        has_bad_calls_for_load <-
            any(calls %in% .bad_call_names_in_startup_functions$load)
        has_bad_calls_for_output <-
            any(calls %in% .bad_call_names_in_startup_functions$output)
        has_unsafe_calls <-
            any(calls %in% .bad_call_names_in_startup_functions$unsafe)

        .fmt_entries_for_file <- function(e, f) {
            c(gettextf("File %s:", sQuote(f)),
              unlist(Map(.fmt_entries_for_function, e, names(e))),
              "")
        }

        .fmt_entries_for_function <- function(e, f) {
            c(if(length(bad <- e[["bad_arg_names"]])) {
                gettextf("  %s has wrong argument list %s",
                         f, sQuote(paste(bad, collapse = ", ")))
            },
              if(length(bad <- e[["bad_calls"]])) {
                  c(gettextf("  %s calls:", f),
                    paste0("    ",
                           unlist(lapply(bad[["calls"]], function(e)
                                         paste(deparse(e), collapse = "")))))
              })
        }

        res <-
            c(res,
              unlist(Map(.fmt_entries_for_file, x, names(x)),
                     use.names = FALSE),
              if(has_bad_wrong_args)
              strwrap(gettextf("Package startup functions should have two arguments with names starting with %s and %s, respectively.",
                               sQuote("lib"), sQuote("pkg")),
                      exdent = 2L),
              if(has_bad_calls_for_load)
              strwrap(gettextf("Package startup functions should not change the search path."),
                      exdent = 2L),
              if(has_bad_calls_for_output)
              strwrap(gettextf("Package startup functions should use %s to generate messages.",
                               sQuote("packageStartupMessage")),
                      exdent = 2L),
              if(has_unsafe_calls)
              strwrap(gettextf("Package startup functions should not call %s.",
                               sQuote("installed.packages")),
                      exdent = 2L),
              gettextf("See section %s in '%s'.",
                       sQuote("Good practice"),
                       "?.onAttach")
              )
    }
    res
}

.bad_call_names_in_startup_functions <-
    list(load = c("library", "require"),
         output = c("cat", "message", "print", "writeLines"),
         unsafe = c("installed.packages", "utils::installed.packages"))

.get_startup_function_calls_in_file <-
function(file, encoding = NA)
{
    exprs <- .parse_code_file(file, encoding)

    ## Use a custom gatherer rather than .find_calls() with a suitable
    ## predicate so that we record the name of the startup function in
    ## which the calls were found.
    calls <- list()
    for(e in exprs) {
        if((length(e) > 2L) &&
	   (is.name(x <- e[[1L]])) &&
           (as.character(x) %in%
            c("<-", "=")) &&
           (as.character(y <- e[[2L]]) %in%
            c(".First.lib", ".onAttach", ".onLoad")) &&
	   (is.call(z <- e[[3L]])) &&
           (as.character(z[[1L]]) == "function")) {
            new <- list(z)
            names(new) <- as.character(y)
            calls <- c(calls, new)
        }
    }
    calls
}

.call_names <-
function(x)
    as.character(sapply(x, function(e) deparse(e[[1L]])))


### * .check_package_code_unload_functions

.check_package_code_unload_functions <-
function(dir)
{
    bad_call_names <- "library.dynam.unload"

    .check_unload_function <- function(fcode, fname) {
        out <- list()
        nms <- names(fcode[[2L]])
        ## Check names of formals.
        ## Allow anything containing ... (for now); otherwise, insist on
        ## length one with names starting with lib.
        if(is.na(match("...", nms)) &&
           (length(nms) != 1L || substring(nms, 1L, 3L) != "lib"))
            out$bad_arg_names <- nms
        ## Look at all calls (not only at top level).
        calls <- .find_calls(fcode[[3L]], recursive = TRUE)
        if(!length(calls)) return(out)
        cnames <- .call_names(calls)
        ## And pick the ones which should not be there ...
        ind <- cnames %in% bad_call_names
        if(any(ind))
            out$bad_calls <- list(calls = calls[ind], names = cnames[ind])
        out
    }

    calls <- .find_calls_in_package_code(dir,
                                         .worker =
                                         .get_unload_function_calls_in_file)
    LL <- unlist(lapply(calls, "[[", ".Last.lib"))
    calls <- Filter(length,
                    lapply(calls,
                           function(e)
                           Filter(length,
                                  Map(.check_unload_function,
                                      e, names(e)))))
    if(length(LL)) {
        code_objs <- ".Last.lib"
        nsInfo <- parseNamespaceFile(basename(dir), dirname(dir))
        OK <- intersect(code_objs, nsInfo$exports)
        for(p in nsInfo$exportPatterns)
            OK <- c(OK, grep(p, code_objs, value = TRUE))
        if(!length(OK)) attr(calls, ".Last.lib") <- TRUE
    }
    class(calls) <- "check_package_code_unload_functions"
    calls
}

format.check_package_code_unload_functions <-
function(x, ...)
{
    res <- if(!is.null(attr(x, ".Last.lib"))) "NB: .Last.lib will not be used unless it is exported" else character()
    if(length(x)) {

        ## Flatten out doubly recursive list of functions within list of
        ## files structure for computing summary messages.
        y <- unlist(x, recursive = FALSE)

        has_bad_wrong_args <-
            "bad_arg_names" %in% unlist(lapply(y, names))
        calls <-
            unique(unlist(lapply(y,
                                 function(e) e[["bad_calls"]][["names"]])))
        .fmt_entries_for_file <- function(e, f) {
            c(gettextf("File %s:", sQuote(f)),
              unlist(Map(.fmt_entries_for_function, e, names(e))),
              "")
        }

        .fmt_entries_for_function <- function(e, f) {
            c(if(length(bad <- e[["bad_arg_names"]])) {
                gettextf("  %s has wrong argument list %s",
                         f, sQuote(paste(bad, collapse = ", ")))
            },
              if(length(bad <- e[["bad_calls"]])) {
                  c(gettextf("  %s calls:", f),
                    paste0("    ",
                           unlist(lapply(bad[["calls"]], function(e)
                                         paste(deparse(e), collapse = "")))))
              })
        }

        res <-
            c(res,
              unlist(Map(.fmt_entries_for_file, x, names(x)),
                     use.names = FALSE),
              if(has_bad_wrong_args)
              strwrap(gettextf("Package detach functions should have one arguments with names starting with %s.", sQuote("lib")),
                      exdent = 2L),
              if(length(call))
              strwrap(gettextf("Package detach functions should not call %s.",
                               sQuote("library.dynam.unload")),
                      exdent = 2L),
              gettextf("See section %s in '%s'.",
                       sQuote("Good practice"), "?.Last.lib")
              )
    }
    res
}

.get_unload_function_calls_in_file <-
function(file, encoding = NA)
{
    exprs <- .parse_code_file(file, encoding)

    ## Use a custom gatherer rather than .find_calls() with a suitable
    ## predicate so that we record the name of the unload function in
    ## which the calls were found.
    calls <- list()
    for(e in exprs) {
        if((length(e) > 2L) &&
	   (is.name(x <- e[[1L]])) &&
           (as.character(x) %in%
            c("<-", "=")) &&
           (as.character(y <- e[[2L]]) %in%
            c(".Last.lib", ".onDetach")) &&
	   (is.call(z <- e[[3L]])) &&
           (as.character(z[[1L]]) == "function")) {
            new <- list(z)
            names(new) <- as.character(y)
            calls <- c(calls, new)
        }
    }
    calls
}

### * .check_package_code_tampers

.check_package_code_tampers <-
function(dir)
{
    dfile <- file.path(dir, "DESCRIPTION")
    pkgname <- if(file.exists(dfile))
        .read_description(dfile)["Package"] else ""

    predicate <- function(e) {
        if(length(e) <= 1L) return(FALSE)
        if(as.character(e[[1L]])[1L] %in% "unlockBinding") {
            e3 <- as.character(e[[3L]])
            if (e3[[1L]] == "asNamespace") e3 <- as.character(e[[3L]][[2L]])
            return(e3 != pkgname)
        }
        if((as.character(e[[1L]])[1L] %in% ".Internal") &&
           as.character(e[[2L]][[1L]]) == "unlockBinding") return(TRUE)
        if(as.character(e[[1L]])[1L] %in% "assignInNamespace") {
            e3 <- as.character(e[[4L]])
            if (e3 == "asNamespace") e3 <- as.character(e[[4L]][[2L]])
            return(e3 != pkgname)
        }
        FALSE
    }

    x <- Filter(length,
                .find_calls_in_package_code(dir, predicate,
                                            recursive = TRUE))

    ## Because we really only need this for calling from R CMD check, we
    ## produce output here in case we found something.
    if(length(x))
        writeLines(unlist(Map(.format_calls_in_file, x, names(x))))
    ## (Could easily provide format() and print() methods ...)

    invisible(x)
}

### * .check_package_code_assign_to_globalenv

.check_package_code_assign_to_globalenv <-
function(dir)
{
    predicate <- function(e) {
        if(!is.call(e) || as.character(e[[1L]]) != "assign")
            return(FALSE)
        e <- e[as.character(e) != "..."]
        ## Capture assignments to global env unless to .Random.seed.
        ## (This may fail for conditionalized code not meant for R
        ## [e.g., argument 'where'].)
        mc <- tryCatch(match.call(base::assign, e), error = identity)
        if(inherits(mc, "error") || mc$x == ".Random.seed")
            return(FALSE)
        if(!is.null(env <- mc$envir) &&
           identical(tryCatch(eval(env),
                              error = identity),
                     globalenv()))
            return(TRUE)
        if(!is.null(pos <- mc$pos) &&
           identical(tryCatch(eval(call("as.environment", pos)),
                              error = identity),
                     globalenv()))
            return(TRUE)
        FALSE
    }

    calls <- Filter(length,
                    .find_calls_in_package_code(dir, predicate,
                                                recursive = TRUE))
    class(calls) <- "check_package_code_assign_to_globalenv"
    calls
}

format.check_package_code_assign_to_globalenv <-
function(x, ...)
{
    if(!length(x)) return(character())

    c("Found the following assignments to the global environment:",
      unlist(Map(.format_calls_in_file, x, names(x))))
}

### * .check_package_code_attach

.check_package_code_attach <-
function(dir)
{
    predicate <- function(e)
        as.character(e[[1L]]) == "attach"

    calls <- Filter(length,
                    .find_calls_in_package_code(dir, predicate,
                                                recursive = TRUE))
    class(calls) <- "check_package_code_attach"
    calls
}

format.check_package_code_attach <-
function(x, ...)
{
    if(!length(x)) return(character())

    c("Found the following calls to attach():",
      unlist(Map(.format_calls_in_file, x, names(x))))
}

### * .check_package_code_data_into_globalenv

.check_package_code_data_into_globalenv <-
function(dir)
{
    predicate <- function(e) {
        if(!is.call(e) || as.character(e[[1L]]) != "data")
            return(FALSE)
        ## As data() has usage
        ##   data(..., list = character(), package = NULL, lib.loc = NULL,
        ##        verbose = getOption("verbose"), envir = .GlobalEnv))
        ## argument 'envir' must be matched exactly, and calls which
        ## only have the last four arguments do not load any data.
        env <- e$envir
        tab <- c("package", "lib.loc", "verbose", "envir")
        if(!is.null(nms <- names(e)))
            e <- e[is.na(match(nms, tab))]
        ((length(e) > 1L) &&
         (is.null(env) ||
          (is.name(env) && as.character(env) == ".GlobalEnv") ||
          (is.call(env) && as.character(env) == "globalenv")))
    }

    calls <- Filter(length,
                    .find_calls_in_package_code(dir, predicate,
                                                recursive = TRUE))
    class(calls) <- "check_package_code_data_into_globalenv"
    calls
}

format.check_package_code_data_into_globalenv <-
function(x, ...)
{
    if(!length(x)) return(character())

    c("Found the following calls to data() loading into the global environment:",
      unlist(Map(.format_calls_in_file, x, names(x))))
}

### * .check_packages_used

.check_packages_used <-
function(package, dir, lib.loc = NULL)
{
    ## Argument handling.
    ns <- NULL
    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        dir <- find.package(package, lib.loc)
        ## Using package installed in @code{dir} ...
        code_dir <- file.path(dir, "R")
        if(!file_test("-d", code_dir))
            stop(gettextf("directory '%s' does not contain R code",
                          dir),
                 domain = NA)
        if(basename(dir) != "base")
            .load_package_quietly(package, lib.loc)
        code_env <- if(packageHasNamespace(package, dirname(dir)))
            asNamespace(package)
        else
            .package_env(package)
        dfile <- file.path(dir, "DESCRIPTION")
        db <- .read_description(dfile)
        ## fake installs do not have this.
        nsfile <- file.path(dir, "Meta", "nsInfo.rds")
        if (file.exists(nsfile)) ns <- readRDS(nsfile)
        else {
            nsfile <- file.path(dir, "NAMESPACE")
            if(file.exists(nsfile))
                ns <- parseNamespaceFile(basename(dir), dirname(dir))
        }
    }
    else if(!missing(dir)) {
        ## Using sources from directory @code{dir} ...
        if(!file_test("-d", dir))
            stop(gettextf("directory '%s' does not exist", dir),
                 domain = NA)
        else
            dir <- file_path_as_absolute(dir)
        dfile <- file.path(dir, "DESCRIPTION")
        db <- .read_description(dfile)
        nsfile <- file.path(dir, "NAMESPACE")
        if(file.exists(nsfile))
           ns <- parseNamespaceFile(basename(dir), dirname(dir))
        code_dir <- file.path(dir, "R")
        if(file_test("-d", code_dir)) {
            file <- tempfile()
            on.exit(unlink(file))
            if(!file.create(file)) stop("unable to create ", file)
            if(!all(.file_append_ensuring_LFs(file,
                                              list_files_with_type(code_dir,
                                                                   "code"))))
                stop("unable to write code files")
        } else return(invisible())
    }
    pkg_name <- db["Package"]
    depends <- .get_requires_from_package_db(db, "Depends")
    imports <- imports0 <- .get_requires_from_package_db(db, "Imports")
    suggests <- .get_requires_from_package_db(db, "Suggests")
    enhances <- .get_requires_from_package_db(db, "Enhances")

    ## it is OK to refer to yourself and non-S4 standard packages
    standard_package_names <-
        setdiff(.get_standard_package_names()$base,
                c("methods", "stats4"))
    ## It helps to know if non-default standard packages are require()d
    default_package_names<-
        setdiff(standard_package_names,
                c("grid", "splines", "tcltk", "tools"))
    depends_suggests <- c(depends, suggests, enhances, pkg_name, default_package_names)
    imports <- c(imports, depends, suggests, enhances, pkg_name,
                 standard_package_names)
    ## the first argument could be named, or could be a variable name.
    ## we just have a stop list here.
    common_names <- c("pkg", "pkgName", "package", "pos")

    bad_exprs <- character()
    bad_imports <- all_imports <- imp2 <- imp2f <- imp3 <- imp3f <- character()
    bad_deps <- character()
    uses_methods <- FALSE
    find_bad_exprs <- function(e) {
        if(is.call(e) || is.expression(e)) {
            Call <- deparse(e[[1L]])[1L]
            if((Call %in% c("library", "require")) &&
               (length(e) >= 2L)) {
                ## We need to rempve '...': OTOH the argument could be NULL
                keep <- sapply(e, function(x) deparse(x)[1L] != "...")
                mc <- match.call(get(Call, baseenv()), e[keep])
                if(!is.null(pkg <- mc$package)) {
                    ## <NOTE>
                    ## Using code analysis, we really don't know which
                    ## package was called if character.only = TRUE and
                    ## the package argument is not a string constant.
                    ## (BTW, what if character.only is given a value
                    ## which is an expression evaluating to TRUE?)
                    dunno <- FALSE
                    if(identical(mc$character.only, TRUE)
                       && !identical(class(pkg), "character"))
                        dunno <- TRUE
                    ## </NOTE>
                    ## <FIXME> could be inside substitute or a variable
                    ## and is in e.g. R.oo
                    if(!dunno) {
                        pkg <- sub('^"(.*)"$', '\\1', deparse(pkg))
                        if(! pkg %in% c(depends_suggests, common_names))
                            bad_exprs <<- c(bad_exprs, pkg)
                        if(pkg %in% depends)
                            bad_deps <<- c(bad_deps, pkg)
                    }
                }
            } else if(Call %in% "::") {
                pkg <- deparse(e[[2L]])
                all_imports <<- c(all_imports, pkg)
                if(! pkg %in% imports)
                    bad_imports <<- c(bad_imports, pkg)
                else {
                    imp2 <<- c(imp2, pkg)
                    imp2f <<- c(imp2f, deparse(e[[3L]]))
                }
            } else if(Call %in% ":::") {
                pkg <- deparse(e[[2L]])
                all_imports <<- c(all_imports, pkg)
                imp3 <<- c(imp3, pkg)
                imp3f <<- c(imp3f, deparse(e[[3L]]))
                if(! pkg %in% imports)
                    bad_imports <<- c(bad_imports, pkg)
            } else if(Call %in% c("setClass", "setMethod")) {
                uses_methods <<- TRUE
            }
            for(i in seq_along(e)) Recall(e[[i]])
        }
    }

    if(!missing(package)) {
        ## <FIXME>
        ## Suggested way of checking for S4 metadata.
        ## Change to use as envir_has_S4_metadata() once this makes it
        ## into base or methods.
        if(length(objects(code_env, all.names = TRUE,
                          pattern = "^[.]__[CT]_")))
            uses_methods <- TRUE
        ## </FIXME>
        exprs <- lapply(ls(envir = code_env, all.names = TRUE),
                        function(f) {
                            f <- get(f, envir = code_env) # get is expensive
			    if(typeof(f) == "closure") body(f) # else NULL
                        })
        if(.isMethodsDispatchOn()) {
            ## Also check the code in S4 methods.
            ## This may find things twice.
            for(f in .get_S4_generics(code_env)) {
                mlist <- .get_S4_methods_list(f, code_env)
                exprs <- c(exprs, lapply(mlist, body))
            }
        }
    }
    else {
        enc <- db["Encoding"]
        if(!is.na(enc) &&
           !(Sys.getlocale("LC_CTYPE") %in% c("C", "POSIX"))) {
            ## FIXME: what if conversion fails on e.g. UTF-8 comments
	    con <- file(file, encoding=enc)
            on.exit(close(con))
        } else con <- file
        exprs <-
            tryCatch(parse(file = con, n = -1L),
                     error = function(e)
                     stop(gettextf("parse error in file '%s':\n%s",
                                   file,
                                   .massage_file_parse_error_message(conditionMessage(e))),
                               domain = NA, call. = FALSE))
    }

    for(i in seq_along(exprs)) find_bad_exprs(exprs[[i]])

    depends_not_import <- character()
    if(length(ns)) {
        imp <- c(ns$imports, ns$importClasses, ns$importMethods)
        if (length(imp)) {
            imp <- sapply(imp, function(x) x[[1L]])
            all_imports <- unique(c(imp, all_imports))
        }
    } else imp <- character()
    bad_imp <- setdiff(imports0, all_imports)
    depends_not_import <- setdiff(depends, c(imp, standard_package_names))

    methods_message <-
        if(uses_methods && !"methods" %in% c(depends, imports))
            gettext("package 'methods' is used but not declared")
        else ""

    extras <- list(
        base = c("Sys.junction", "shell", "shell.exec"),
        grDevices = c("X11.options", "X11Font", "X11Fonts", "quartz",
        "quartz.options", "quartz.save", "quartzFont", "quartzFonts",
        "bringToTop", "msgWindow", "win.graph", "win.metafile", "win.print",
        "windows", "windows.options", "windowsFont", "windowsFonts"),
        parallel = c("mccollect", "mcparallel", "mc.reset.stream", "mcaffinity"),
        utils = c("nsl", "DLL.version", "Filters",
        "choose.dir", "choose.files", "getClipboardFormats",
        "getIdentification", "getWindowsHandle", "getWindowsHandles",
        "getWindowTitle", "loadRconsole", "readClipboard",
        "readRegistry", "setStatusBar", "setWindowTitle",
        "shortPathName", "win.version", "winDialog",
        "winDialogString", "winMenuAdd", "winMenuAddItem",
        "winMenuDel", "winMenuDelItem", "winMenuNames",
        "winMenuItems", "writeClipboard", "zip.unpack",
        "winProgressBar", "getWinProgressBar", "setWinProgressBar",
        "setInternet2", "arrangeWindows"),
        RODBC = c("odbcConnectAccess", "odbcConnectAccess2007",
        "odbcConnectDbase", "odbcConnectExcel", "odbcConnectExcel2007")
        )
    imp2un <- character()
    if(length(imp2)) { ## Try to check these are exported
        names(imp2f) <- imp2
        imp2 <- unique(imp2)
        imps <- split(imp2f, names(imp2f))
        for (p in names(imps)) {
            ## some people have these quoted:
            this <- imps[[p]]
            this <- sub('^"(.*)"$', "\\1", this)
            this <- sub("^'(.*)'$", "\\1", this)
            if (p %in% "base") {
                this <- setdiff(this, ls(baseenv(), all.names = TRUE))
                if(length(this))
                    imp2un <- c(imp2un, paste(p, this, sep = "::"))
                next
            }
            ns <- .getNamespace(p)
            value <- if(is.null(ns)) {
                ## this could be noisy
                tryCatch(suppressWarnings(suppressMessages(loadNamespace(p))),
                         error = function(e) e)
            } else NULL
            if (!inherits(value, "error")) {
                exps <- c(ls(envir = getNamespaceInfo(p, "exports"),
                             all.names = TRUE), extras[[p]])
                this2 <- setdiff(this, exps)
                if(length(this2))
                    imp2un <- c(imp2un, paste(p, this2, sep = "::"))
            }
        }
    }

    names(imp3f) <- imp3
    imp3 <- unique(imp3)
    imp3self <- pkg_name %in% imp3
    imp3selfcalls <- as.vector(imp3f[names(imp3f) == pkg_name])
    imp3 <- setdiff(imp3, pkg_name)
    if(length(imp3)) {
        imp3f <- imp3f[names(imp3f) %in% imp3]
        imps <- split(imp3f, names(imp3f))
        imp32 <- imp3 <- imp3f <- imp3ff <- unknown <- character()
        for (p in names(imps)) {
            this <- imps[[p]]
            this <- sub('^"(.*)"$', "\\1", this)
            this <- sub("^'(.*)'$", "\\1", this)
            if (p %in% "base") {
                imp32 <- c(imp32, paste(p, this, sep = ":::"))
                next
            }
            ns <- .getNamespace(p)
            value <- if(is.null(ns)) {
                ## this could be noisy
                tryCatch(suppressWarnings(suppressMessages(loadNamespace(p))),
                         error = function(e) e)
            } else NULL
            if (inherits(value, "error")) {
                unknown <- c(unknown, p)
            } else {
                 exps <- c(ls(envir = getNamespaceInfo(p, "exports"),
                              all.names = TRUE), extras[[p]])
                 this2 <- this %in% exps
                 if (any(this2))
                     imp32 <- c(imp32, paste(p, this[this2], sep = ":::"))
                 if (any(!this2)) {
                     imp3 <- c(imp3, p)
                     this <- this[!this2]
                     pp <- ls(envir = asNamespace(p), all.names = TRUE)
                     this2 <- this %in% pp
                     if(any(this2))
                         imp3f <- c(imp3f, paste(p, this[this2], sep = ":::"))
                     if(any(!this2))
                         imp3ff <- c(imp3ff, paste(p, this[!this2], sep = ":::"))
                 }
            }
        }
        if(length(imp3f)) {
            ## remove other packages which have the same maintainer,
            ## but report references to itself.  Unless they should be :: .
            maintainers <-
                sapply(strsplit(imp3f, ":::", fixed = TRUE),
                       function(p) {
                           dfile <- system.file("DESCRIPTION", package = p[[1L]])
                           if(dfile == "") return("")
                           unname(.read_description(dfile)["Maintainer"])
                       })
            imp3f <- imp3f[(maintainers != db["Maintainer"])]
        }
    } else imp32 <- imp3f <- imp3ff <- unknown <- character()
    res <- list(others = unique(bad_exprs),
                imports = unique(bad_imports),
                in_depends = unique(bad_deps),
                unused_imports = bad_imp,
                depends_not_import = depends_not_import,
                imp2un = sort(unique(imp2un)),
                imp32 = sort(unique(imp32)),
                imp3 = imp3, imp3f = sort(unique(imp3f)),
                imp3ff = sort(unique(imp3ff)),
                imp3self = imp3self,
                imp3selfcalls = sort(unique(imp3selfcalls)),
                imp3unknown = unknown,
                methods_message = methods_message)
    class(res) <- "check_packages_used"
    res
}

format.check_packages_used <-
function(x, ...)
{
    incoming <-
        identical(Sys.getenv("_R_CHECK_PACKAGES_USED_CRAN_INCOMING_NOTES_",
                             "FALSE"),
                  "TRUE")
    c(character(),
      if(length(xx <- x$imports)) {
          if(length(xx) > 1L) {
              c(gettext("'::' or ':::' imports not declared from:"),
                .pretty_format(sort(xx)))
          } else {
              gettextf("'::' or ':::' import not declared from: %s", sQuote(xx))
          }
      },
      if(length(xx <- x$others)) {
          if(length(xx) > 1L) {
              c(gettext("'library' or 'require' calls not declared from:"),
                .pretty_format(sort(xx)))
          } else {
              gettextf("'library' or 'require' call not declared from: %s",
                       sQuote(xx))
          }
      },
      if(length(xx <- x$in_depends)) {
          msg <- "  Please remove these calls from your code."
          if(length(xx) > 1L) {
              c(gettext("'library' or 'require' calls to packages already attached by Depends:"),
                .pretty_format(sort(xx)), msg)
          } else {
              c(gettextf("'library' or 'require' call to %s which was already attached by Depends.",
                         sQuote(xx)), msg)
          }
      },
      if(length(xx <- x$unused_imports)) {
          msg <- "  All declared Imports should be used."
          if(length(xx) > 1L) {
              c(gettext("Namespaces in Imports field not imported from:"),
                .pretty_format(sort(xx)), msg)
          } else {
              c(gettextf("Namespace in Imports field not imported from: %s",
                       sQuote(xx)), msg)
          }
      },
      if(length(xx <- x$depends_not_import)) {
          msg <- c("  These packages need to be imported from (in the NAMESPACE file)",
                   "  for when this namespace is loaded but not attached.")
          if(length(xx) > 1L) {
              c(gettext("Packages in Depends field not imported from:"),
                .pretty_format(sort(xx)), msg)
          } else {
              c(gettextf("Package in Depends field not imported from: %s",
                         sQuote(xx)), msg)
          }
      },
      if(length(xx <- x$imp2un)) {
          if(length(xx) > 1L) {
              c(gettext("Missing or unexported objects:"),
                .pretty_format(sort(xx)))
          } else {
              gettextf("Missing or unexported object: %s", sQuote(xx))
          }
      },
      if(length(xx <- x$imp32)) { ## ' ' seems to get converted to dir quotes
          msg <- "See the note in ?`:::` about the use of this operator."
          msg <- strwrap(paste(msg, collapse = " "), indent = 2L, exdent = 2L)
          if(length(xx) > 1L) {
              c(gettext("':::' calls which should be '::':"),
                .pretty_format(sort(xx)), msg)
          } else {
              c(gettextf("':::' call which should be '::': %s",
                         sQuote(xx)), msg)
          }
      },
      if(length(xx <- x$imp3ff)) {
           if(length(xx) > 1L) {
              c(gettext("Missing objects imported by ':::' calls:"),
                .pretty_format(sort(xx)))
          } else {
              gettextf("Missing object imported by a ':::' call: %s",
                       sQuote(xx))
          }
     },
      if(length(xxx <- x$imp3f)) { ## ' ' seems to get converted to dir quotes
          msg <- "See the note in ?`:::` about the use of this operator."
          msg <- strwrap(paste(msg, collapse = " "), indent = 2L, exdent = 2L)
          if(incoming) {
              z <- sub(":::.*", "", xxx)
              base <- unlist(.get_standard_package_names()[c("base", "recommended")])
              if (any(z %in% base))
                  msg <- c(msg,
                           "  Including base/recommended package(s):",
                           .pretty_format(intersect(base, z)))
          }
          if(length(xxx) > 1L) {
              c(gettext("Unexported objects imported by ':::' calls:"),
                .pretty_format(sort(xxx)), msg)
          } else  if(length(xxx)) {
              c(gettextf("Unexported object imported by a ':::' call: %s",
                         sQuote(xxx)), msg)
          }
      },
      if(identical(x$imp3self, TRUE)) {
          msg <-
              c("There are ::: calls to the package's namespace in its code.",
                "A package almost never needs to use ::: for its own objects:")
          c(strwrap(paste(msg, collapse = " "), indent = 0L, exdent = 2L),
            .pretty_format(sort(x$imp3selfcalls)))
      },
      if(length(xx <- x$imp3unknown)) {
          msg <- "See the note in ?`:::` about the use of this operator."
          msg <- strwrap(paste(msg, collapse = " "), indent = 2L, exdent = 2L)
          if(length(xx) > 1L) {
              c(gettext("Unavailable namespaces imported from by ':::' calls:"),
                .pretty_format(sort(xx)), msg)
          } else {
              c(gettextf("Unavailable namespace imported from by a ':::' call: %s",
                         sQuote(xx)), msg)
          }
      },
      if(length(xx <- x$data)) {
          if(length(xx) > 1L) {
              c(gettext("'data(package=)' calls not declared from:"),
                .pretty_format(sort(xx)))
          } else {
              gettextf("'data(package=)' call not declared from: %s",
                       sQuote(xx))
          }
      },
      if(nzchar(x$methods_message)) {
          x$methods_message
      })
}

### * .check_packages_used_in_examples

.check_packages_used_helper <-
function(db, files)
{
    pkg_name <- db["Package"]
    depends <- .get_requires_from_package_db(db, "Depends")
    imports <- .get_requires_from_package_db(db, "Imports")
    suggests <- .get_requires_from_package_db(db, "Suggests")
    enhances <- .get_requires_from_package_db(db, "Enhances")

    ## it is OK to refer to yourself and standard packages
    standard_package_names <- .get_standard_package_names()$base
    depends_suggests <- c(depends, imports, suggests, enhances, pkg_name,
                          standard_package_names)
    ## the first argument could be named, or could be a variable name.
    ## we just have a stop list here.
    common_names <- c("pkg", "pkgName", "package", "pos")

    bad_exprs <- character()
    bad_imports <- character()
    bad_data <- character()
    find_bad_exprs <- function(e) {
        if(is.call(e) || is.expression(e)) {
            Call <- deparse(e[[1L]])[1L]
            if(length(e) >= 2L) pkg <- deparse(e[[2L]])
            if(Call %in% c("library", "require")) {
                if(length(e) >= 2L) {
                    ## We need to rempve '...': OTOH the argument could be NULL
                    keep <- sapply(e, function(x) deparse(x)[1L] != "...")
                    mc <- match.call(get(Call, baseenv()), e[keep])
                    if(!is.null(pkg <- mc$package)) {
                        pkg <- sub('^"(.*)"$', '\\1', pkg)
                        ## <NOTE>
                        ## Using code analysis, we really don't know which
                        ## package was called if character.only = TRUE and
                        ## the package argument is not a string constant.
                        ## (Btw, what if character.only is given a value
                        ## which is an expression evaluating to TRUE?)
                        dunno <- FALSE
                        pos <- which(!is.na(pmatch(names(e),
                                                   "character.only")))
                        if(length(pos)
                           && identical(e[[pos]], TRUE)
                           && !identical(class(e[[2L]]), "character"))
                            dunno <- TRUE
                        ## </NOTE>
                        if(! dunno
                           && ! pkg %in% c(depends_suggests, common_names))
                            bad_exprs <<- c(bad_exprs, pkg)
                    }
                }
            } else if(Call %in%  "::") {
                if(! pkg %in% depends_suggests)
                    bad_imports <<- c(bad_imports, pkg)
            } else if(Call %in%  ":::") {
                if(! pkg %in% depends_suggests)
                    bad_imports <<- c(bad_imports, pkg)
            } else if(Call %in%  "data" && length(e) >= 3L) {
                mc <- match.call(utils::data, e)
                if(!is.null(pkg <- mc$package) && !pkg %in% depends_suggests)
                    bad_data <<- c(bad_data, pkg)
            } else if(deparse(e[[1L]])[1L] %in% c("utils::data", "utils:::data")) {
                mc <- match.call(utils::data, e)
                if(!is.null(pkg <- mc$package) && !pkg %in% depends_suggests)
                    bad_data <<- c(bad_data, pkg)
            }

            for(i in seq_along(e)) Recall(e[[i]])
        }
    }

    if (is.character(files)) {
        for (f in files) {
            tryCatch({
                exprs <- parse(file = f, n = -1L)
                for(i in seq_along(exprs)) find_bad_exprs(exprs[[i]])
            },
                     error = function(e)
                     warning(gettextf("parse error in file '%s':\n%s", f,
                                      .massage_file_parse_error_message(conditionMessage(e))),
                             domain = NA, call. = FALSE))
        }
    } else {
        ## called for examples with translation
        tryCatch({
            exprs <- parse(file = files, n = -1L)
            for(i in seq_along(exprs)) find_bad_exprs(exprs[[i]])
        },
                 error = function(e)
                 warning(gettextf("parse error in file '%s':\n%s",
                                  summary(files)$description,
                                  .massage_file_parse_error_message(conditionMessage(e))),
                         domain = NA, call. = FALSE))
    }

    res <- list(others = unique(bad_exprs),
                imports = unique(bad_imports),
                data = unique(bad_data),
                methods_message = "")
    class(res) <- "check_packages_used"
    res
}

.check_packages_used_in_examples <-
function(package, dir, lib.loc = NULL)
{
    ## Argument handling.
    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        dir <- find.package(package, lib.loc)
        dfile <- file.path(dir, "DESCRIPTION")
        db <- .read_description(dfile)
    }
    else if(!missing(dir)) {
        ## Using sources from directory @code{dir} ...
        ## FIXME: not yet supported by .createExdotR.
        if(!file_test("-d", dir))
            stop(gettextf("directory '%s' does not exist", dir), domain = NA)
        else
            dir <- file_path_as_absolute(dir)
        dfile <- file.path(dir, "DESCRIPTION")
        db <- .read_description(dfile)
    }
    pkg_name <- db["Package"]

    file <- .createExdotR(pkg_name, dir, silent = TRUE)
    if (is.null(file)) return(invisible(NULL)) # e.g, no examples
    on.exit(unlink(file))
    enc <- db["Encoding"]
    if(!is.na(enc) &&
       !(Sys.getlocale("LC_CTYPE") %in% c("C", "POSIX"))) {
        ## FIXME: what if conversion fails on e.g. UTF-8 comments
        con <- file(file, encoding=enc)
        on.exit(close(con))
    } else con <- file

    .check_packages_used_helper(db, con)
}


### * .check_packages_used_in_tests

.check_packages_used_in_tests <-
function(dir, lib.loc = NULL)
{
    ## Argument handling.
    ## Using sources from directory @code{dir} ...
    if(!file_test("-d", dir))
        stop(gettextf("directory '%s' does not exist", dir), domain = NA)
    else
        dir <- file_path_as_absolute(dir)
    dfile <- file.path(dir, "DESCRIPTION")
    db <- .read_description(dfile)

    testsrcdir <- file.path(dir, "tests")
    od <- setwd(testsrcdir)
    on.exit(setwd(od))
    Rinfiles <- dir(".", pattern="\\.Rin$") # only trackOjs has *.Rin
    Rfiles <- dir(".", pattern="\\.R$")
    .check_packages_used_helper(db, c(Rinfiles, Rfiles))
}

### * .check_packages_used_in_vignettes

.check_packages_used_in_vignettes <-
function(package, lib.loc = NULL)
{
    ## Argument handling.
    if(missing(package) || length(package) != 1L)
        stop("argument 'package' must be of length 1")
    dir <- find.package(package, lib.loc)
    ## FIXME: use Meta directory.
    db <- .read_description(file.path(dir, "DESCRIPTION"))
    vinfo <- pkgVignettes(dir = dir, subdirs = "doc", source = TRUE)
    Rfiles <- unique(as.character(unlist(vinfo$sources)))
    .check_packages_used_helper(db, Rfiles)
}

### * .check_T_and_F

## T and F checking, next generation.
##
## What are we really trying to do?
##
## In R, T and F are "just" variables which upon startup are bound to
## TRUE and FALSE, respectively, in the base package/namespace.  Hence,
## if code uses "global" variables T and F and dynamic lookup is in
## place (for packages, if they do not have a namespace), there may be
## trouble in case T or F were redefined.  So we'd like to warn about
## these cases.
##
## A few things to note:
## * Package code top-level bindings *to* T and F are not a problem for
##   packages installed for lazy-loading (as the top-level T and F get
##   evaluated "appropriately" upon installation.
## * Code in examples using "global" T and F is always a problem, as
##   this is evaluated in the global envionment by examples().
## * There is no problem with package code using T and F as local
##   variables.
## * Functions in a namespace will always find the T or F in the
##   namespace, imports or base, never in the global environment.
##
## Our current idea is the following.  Function findGlobals() in
## codetools already provides a way to (approximately) determine the
## globals.  So we can try to get these and report them.
##
## Note that findGlobals() only works on closures, so we definitely miss
## top-level assignments to T or F.  This could be taken care of rather
## easily, though.
##
## Note also that we'd like to help people find where the offending
## globals were found.  Seems that codetools currently does not offer a
## way of recording e.g. the parent expression, so we do our own thing
## based on the legacy checkTnF code.

.check_T_and_F <-
function(package, dir, lib.loc = NULL)
{
    ## Seems that checking examples has several problems, and can result
    ## in "strange" diagnostic output.  Let's more or less disable this
    ## for the time being.
    check_examples <-
        isTRUE(as.logical(Sys.getenv("_R_CHECK_RD_EXAMPLES_T_AND_F_")))


    bad_closures <- character()
    bad_examples <- character()

    find_bad_closures <- function(env) {
        objects_in_env <- objects(env, all.names = TRUE)
        x <- lapply(objects_in_env,
                    function(o) {
                        v <- get(o, envir = env)
                        if (typeof(v) == "closure")
                            codetools::findGlobals(v)
                    })
        objects_in_env[sapply(x,
                              function(s) any(s %in% c("T", "F")))]
    }

    find_bad_examples <- function(txts) {
        env <- new.env(hash = TRUE) # might be many
        x <- lapply(txts,
                    function(txt) {
                        tryCatch({
                            eval(parse(text =
                                       paste("FOO <- function() {",
                                             paste(txt, collapse = "\n"),
                                             "}",
                                             collapse = "\n")),
                                 env)
                            find_bad_closures(env)
                        },
                                 error = function(e) character())
                    })
        names(txts)[sapply(x, length) > 0L]
    }

    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        dir <- find.package(package, lib.loc)
        if((package != "base")
           && !packageHasNamespace(package, dirname(dir))) {
            .load_package_quietly(package, lib.loc)
            code_env <- .package_env(package)
            bad_closures <- find_bad_closures(code_env)
        }
        if(check_examples)
            example_texts <-
                .get_example_texts_from_example_dir(file.path(dir, "R-ex"))
    }
    else {
        ## The dir case.
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        dir <- file_path_as_absolute(dir)
        code_dir <- file.path(dir, "R")
        if(!packageHasNamespace(basename(dir), dirname(dir))
           && file_test("-d", code_dir)) {
            code_env <- new.env(hash = TRUE)
            dfile <- file.path(dir, "DESCRIPTION")
            meta <- if(file_test("-f", dfile))
                .read_description(dfile)
            else
                character()
            .source_assignments_in_code_dir(code_dir, code_env, meta)
            bad_closures <- find_bad_closures(code_env)
        }
        if(check_examples)
            example_texts <- .get_example_texts_from_source_dir(dir)
    }

    if(check_examples)
        bad_examples <- find_bad_examples(example_texts)

    out <- list(bad_closures = bad_closures,
                bad_examples = bad_examples)
    class(out) <- "check_T_and_F"
    out
}

.get_example_texts_from_example_dir <-
function(dir)
{
    if(!file_test("-d", dir)) return(NULL)
    files <- list_files_with_exts(dir, "R")
    texts <- lapply(files,
                    function(f) paste(readLines(f, warn = FALSE),
                                      collapse = "\n"))
    names(texts) <- files
    texts
}

.get_example_texts_from_source_dir <-
function(dir)
{
    if(!file_test("-d", file.path(dir, "man"))) return(NULL)
    sapply(Rd_db(dir = dir), .Rd_get_example_code)
}

format.check_T_and_F <-
function(x, ...)
{
    c(character(),
      if(length(x$bad_closures)) {
          msg <- ngettext(length(x$bad_closures),
                          "Found possibly global 'T' or 'F' in the following function:",
                          "Found possibly global 'T' or 'F' in the following functions:"
                          )
          c(strwrap(msg),
            .pretty_format(x$bad_closures))
      },
      if(length(x$bad_examples)) {
          msg <- ngettext(length(x$bad_examples),
                          "Found possibly global 'T' or 'F' in the examples of the following Rd file:",
                          "Found possibly global 'T' or 'F' in the examples of the following Rd files:"
                          )
          c(strwrap(msg),
            paste(" ", x$bad_examples))
      })
}

### * .check_dotIntenal

.check_dotInternal <-
function(package, dir, lib.loc = NULL, details = TRUE)
{
    bad_closures <- character()

    find_bad_closures <- function(env) {
        objects_in_env <- objects(env, all.names = TRUE)
        x <- lapply(objects_in_env,
                    function(o) {
                        v <- get(o, envir = env)
                        if (typeof(v) == "closure")
                            codetools::findGlobals(v)
                    })
        objects_in_env[sapply(x, function(s) any(s %in% ".Internal"))]
    }

    find_bad_S4methods <- function(env) {
        gens <- .get_S4_generics(code_env)
        x <- lapply(gens, function(f) {
            tab <- get(methods:::.TableMetaName(f, attr(f, "package")),
                       envir = code_env)
            ## The S4 'system' does **copy** base code into packages ....
            any(unlist(eapply(tab, function(v) !inherits(v, "derivedDefaultMethod") && any(codetools::findGlobals(v) %in% ".Internal"))))
        })
        gens[unlist(x)]
    }

    find_bad_refClasses <- function(refs) {
        cl <- names(refs)
        x <- lapply(refs, function(z) {
            any(unlist(sapply(z, function(v) any(codetools::findGlobals(v) %in% ".Internal"))))
        })
        cl[unlist(x)]
    }


    bad_S4methods <- list()
    bad_refs <- character()
    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        dir <- find.package(package, lib.loc)
        if(! package %in% .get_standard_package_names()$base) {
            .load_package_quietly(package, lib.loc)
            code_env <- if(packageHasNamespace(package, dirname(dir)))
                           asNamespace(package)
            else .package_env(package)
            bad_closures <- find_bad_closures(code_env)
            if(.isMethodsDispatchOn()) {
                bad_S4methods <- find_bad_S4methods(code_env)
                refs <- .get_ref_classes(code_env)
                if(length(refs)) bad_refs <- find_bad_refClasses(refs)
            }
        }
    }
    else {
        ## The dir case.
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        dir <- file_path_as_absolute(dir)
        code_dir <- file.path(dir, "R")
        if(file_test("-d", code_dir)) {
            code_env <- new.env(hash = TRUE)
            dfile <- file.path(dir, "DESCRIPTION")
            meta <- if(file_test("-f", dfile))
                .read_description(dfile)
            else
                character()
            .source_assignments_in_code_dir(code_dir, code_env, meta)
            bad_closures <- find_bad_closures(code_env)
        }
    }

    internals <- character()
    if (length(bad_closures) && details) {
        lapply(bad_closures, function(o) {
            v <- get(o, envir = code_env)
            calls <- .find_calls(v, recursive = TRUE)
            if(!length(calls)) return()
            calls <- calls[.call_names(calls) == ".Internal"]
            calls2 <- lapply(calls, "[", 2L)
            calls3 <-
                sapply(calls2, function(x) sub("\\(.*", "", deparse(x)[1L]))
            internals <<- c(internals, calls3)
        })
    }
    out <- list(bad_closures = bad_closures, internals = internals,
                bad_S4methods = bad_S4methods, bad_refs = bad_refs)
    class(out) <- "check_dotInternal"
    out
}

format.check_dotInternal <-
function(x, ...)
{
    out <- if(length(x$bad_closures)) {
        msg <- ngettext(length(x$bad_closures),
                        "Found a .Internal call in the following function:",
                        "Found .Internal calls in the following functions:"
                        )
        out <- c(strwrap(msg), .pretty_format(x$bad_closures))
        if (length(unique(x$internals)))
            out <- c(out, "with calls to .Internal functions",
                     .pretty_format(sort(unique(x$internals))))
        out
    } else character()
    if(length(x$bad_S4methods)) {
        msg <- ngettext(length(x$bad_S4methods),
                        "Found a.Internal call in methods for the following S4 generic:",
                        "Found .Internal calls in methods for the following S4 generics:"
                        )
        out <- c(out, strwrap(msg), .pretty_format(x$bad_S4methods))
    }
    if(length(x$bad_refs)) {
        msg <- ngettext(length(x$bad_refs),
                        "Found a .Internal call in methods for the following reference class:",
                        "Found .Internal calls in methods for the following reference classes:"
                        )
        out <- c(out, strwrap(msg), .pretty_format(x$bad_refs))
    }
    out
}

### * .check_namespace

.check_namespace <-
function(dir)
{
    dir <- file_path_as_absolute(dir)
    invisible(tryCatch(parseNamespaceFile(basename(dir), dirname(dir)),
                       error = function(e) {
                           writeLines("Invalid NAMESPACE file, parsing gives:")
                           stop(e)
                       }))
}

### * .check_citation

.check_citation <-
function(cfile, dir = NULL)
{
    cfile <- file_path_as_absolute(cfile)

    if(!is.null(dir)) {
        meta <- utils::packageDescription(basename(dir), dirname(dir))
        db <- tryCatch(suppressMessages(utils::readCitationFile(cfile,
                                                                meta)),
                       error = identity)
        if(inherits(db, "error")) {
            msg <- conditionMessage(db)
            call <- conditionCall(db)
            if(is.null(call))
                msg <- c("Error: ", msg)
            else
                msg <- c("Error in ", deparse(call), ": ", msg)
            writeLines(paste(msg, collapse = ""))
        }
        return(invisible())
    }

    meta <- if(basename(dir <- dirname(cfile)) == "inst")
        as.list(.get_package_metadata(dirname(dir)))
    else
        NULL

    db <- tryCatch(suppressMessages(get_CITATION_entry_fields(cfile,
                                                              meta$Encoding)),
                   error = identity)

    if(inherits(db, "error")) {
        writeLines(conditionMessage(db))
        return(invisible())
    }

    if(!NROW(db)) return(invisible())

    bad <- Map(find_missing_required_BibTeX_fields, db$Entry, db$Fields,
               USE.NAMES = FALSE)
    ind <- sapply(bad, identical, NA_character_)
    if(length(pos <- which(ind))) {
        entries <- db$Entry[pos]
        entries <-
            ifelse(nchar(entries) < 20L,
                   entries,
                   paste(substring(entries, 1L, 20L), "[TRUNCATED]"))
        writeLines(sprintf("entry %d: invalid type %s",
                           pos, sQuote(entries)))
    }
    pos <- which(!ind & (sapply(bad, length) > 0L))
    if(length(pos)) {
        writeLines(strwrap(sprintf("entry %d (%s): missing required field(s) %s",
                                   pos,
                                   db$Entry[pos],
                                   sapply(bad[pos],
                                          function(s)
                                          paste(sQuote(s),
                                                collapse = ", "))),
                           indent = 0L, exdent = 2L))
    }
}

### * .check_package_parseRd

## FIXME: could use dumped files, except for use of encoding = "ASCII"
.check_package_parseRd <-
function(dir, silent = FALSE, def_enc = FALSE, minlevel = -1)
{
    if(file.exists(dfile <- file.path(dir, "DESCRIPTION"))) {
        enc <- read.dcf(dfile)[1L, ]["Encoding"]
        if(is.na(enc)) enc <- "ASCII"
        else def_enc <- TRUE
    } else enc <- "ASCII"
    owd <- setwd(file.path(dir, "man"))
    on.exit(setwd(owd))
    pg <- c(Sys.glob("*.Rd"), Sys.glob("*.rd"),
            Sys.glob(file.path("*", "*.Rd")),
            Sys.glob(file.path("*", "*.rd")))
    ## (Note that using character classes as in '*.[Rr]d' is not
    ## guaranteed to be portable.)
    bad <- character()
    for (f in pg) {
        ## Kludge for now
        if(basename(f) %in%  c("iconv.Rd", "showNonASCII.Rd")) def_enc <- TRUE
	tmp <- tryCatch(suppressMessages(checkRd(f, encoding = enc,
						 def_enc = def_enc)),
			error = function(e)e)
	if(inherits(tmp, "error")) {
	    bad <- c(bad, f)
            if(!silent) message(geterrmessage())
        } else print(tmp, minlevel = minlevel)
    }
    if(length(bad)) bad <- sQuote(sub(".*/", "", bad))
    if(length(bad) > 1L)
        cat("problems found in ", paste(bad, collapse=", "), "\n", sep = "")
    else if(length(bad))
        cat("problem found in ", bad, "\n", sep = "")
    invisible()
}


### * .check_depdef

.check_depdef <-
function(package, dir, lib.loc = NULL, WINDOWS = FALSE)
{
    bad_depr <- c("plclust")

    bad_def <- c("La.eigen", "tetragamma", "pentagamma",
                 "package.description", "gammaCody",
                 "manglePackageName", ".readRDS", ".saveRDS",
                 "mem.limits", "trySilent", "traceOn", "traceOff",
                 "print.coefmat", "anovalist.lm", "lm.fit.null",
                 "lm.wfit.null", "glm.fit.null", "tkcmd",
                 "tkfile.tail", "tkfile.dir", "tkopen", "tkclose",
                 "tkputs", "tkread", "Rd_parse", "CRAN.packages",
                 "zip.file.extract",
                 "real", "as.real", "is.real",
                 ".find.package", ".path.package")

    ## X11 may not work on even a Unix-alike: it needs X support
    ## (optional) at install time and and an X server at run time.
    bad_dev <- c("quartz", "x11", "X11")
    if(!WINDOWS)
        bad_dev <- c(bad_dev,  "windows", "win.graph", "win.metafile", "win.print")

    bad <- c(bad_depr, bad_def, bad_dev)
    bad_closures <- character()
    found <- character()

    find_bad_closures <- function(env) {
        objects_in_env <- objects(env, all.names = TRUE)
        x <- lapply(objects_in_env,
                    function(o) {
                        v <- get(o, envir = env)
                        if (typeof(v) == "closure")
                            codetools::findGlobals(v)
                    })
        objects_in_env[sapply(x, function(s) {
            res <- any(s %in% bad)
            if(res) found <<- c(found, s)
            res
        })]
    }

    find_bad_S4methods <- function(env) {
        gens <- .get_S4_generics(code_env)
        x <- lapply(gens, function(f) {
            tab <- get(methods:::.TableMetaName(f, attr(f, "package")),
                       envir = code_env)
            ## The S4 'system' does **copy** base code into packages ....
            any(unlist(eapply(tab, function(v) {
                if(!inherits(v, "derivedDefaultMethod")) FALSE
                else {
                    s <- codetools::findGlobals(v)
                    found <<- c(found, s)
                    any(s %in% bad)
                }
            })))
        })
        gens[unlist(x)]
    }

    find_bad_refClasses <- function(refs) {
        cl <- names(refs)
        x <- lapply(refs, function(z) {
            any(unlist(sapply(z, function(v) {
                s <- codetools::findGlobals(v)
                found <<- c(found, s)
                any(s %in% bad)
            })))
        })
        cl[unlist(x)]
    }


    bad_S4methods <- list()
    bad_refs <- character()
    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        dir <- find.package(package, lib.loc)
        if(! package %in% .get_standard_package_names()$base) {
            .load_package_quietly(package, lib.loc)
            code_env <- if(packageHasNamespace(package, dirname(dir)))
                           asNamespace(package)
            else .package_env(package)
            bad_closures <- find_bad_closures(code_env)
            if(.isMethodsDispatchOn()) {
                bad_S4methods <- find_bad_S4methods(code_env)
                refs <- .get_ref_classes(code_env)
                if(length(refs)) bad_refs <- find_bad_refClasses(refs)
            }
        }
    }
    else {
        ## The dir case.
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        dir <- file_path_as_absolute(dir)
        code_dir <- file.path(dir, "R")
        if(file_test("-d", code_dir)) {
            code_env <- new.env(hash = TRUE)
            dfile <- file.path(dir, "DESCRIPTION")
            meta <- if(file_test("-f", dfile))
                .read_description(dfile)
            else
                character()
            .source_assignments_in_code_dir(code_dir, code_env, meta)
            bad_closures <- find_bad_closures(code_env)
        }
    }

    found <- sort(unique(found))
    deprecated <- found[found %in% bad_depr]
    defunct <- found[found %in% bad_def]
    devices <- found[found %in% bad_dev]

    out <- list(bad_closures = bad_closures, deprecated = deprecated,
                defunct = defunct, devices = devices)
    class(out) <- "check_depdef"
    out
}

format.check_depdef <-
function(x, ...)
{
    out <- if(length(x$bad_closures)) {
        msg <- ngettext(length(x$bad_closures),
                        "Found an obsolete/platform-specific call in the following function:",
                        "Found an obsolete/platform-specific call in the following functions:"
                        )
        c(strwrap(msg), .pretty_format(x$bad_closures))
    } else character()
    if(length(x$bad_S4methods)) {
        msg <- ngettext(length(x$bad_S4methods),
                        "Found an obsolete/platform-specific call in methods for the following S4 generic:",
                        "Found an obsolete/platform-specific call in methods for the following S4 generics:"
                        )
        out <- c(out, strwrap(msg), .pretty_format(x$bad_S4methods))
    }
    if(length(x$bad_refs)) {
        msg <- ngettext(length(x$bad_refs),
                        "Found an obsolete/platform-specific call in methods for the following reference class:",
                        "Found an obsolete/platform-specific call in methods for the following reference classes:"
                        )
        out <- c(out, strwrap(msg), .pretty_format(x$bad_refs))
    }
    if(length(x$deprecated)) {
        msg <- ngettext(length(x$deprecated),
                        "Found the deprecated function:",
                        "Found the deprecated functions:"
                        )
        out <- c(out, strwrap(msg), .pretty_format(x$deprecated))
    }
    if(length(x$defunct)) {
        msg <- ngettext(length(x$defunct),
                        "Found the defunct/removed function:",
                        "Found the defunct/removed functions:"
                        )
        out <- c(out, strwrap(msg), .pretty_format(x$defunct))
    }
    if(length(x$devices)) {
        msg <- ngettext(length(x$devices),
                        "Found the platform-specific device:",
                        "Found the platform-specific devices:"
                        )
        out <- c(out, strwrap(msg), .pretty_format(x$devices),
                 strwrap(paste("dev.new() is the preferred way to open a new device,",
                               "in the unlikely event one is needed.",
                               collapse = " ")))
    }
    out
}

### * .check_package_CRAN_incoming

.check_package_CRAN_incoming <-
function(dir)
{
    out <- list()
    class(out) <- "check_package_CRAN_incoming"

    meta <- .get_package_metadata(dir, FALSE)
    info <- analyze_license(meta["License"])
    ## Use later to indicate changes from FOSS to non-FOSS licence.
    foss <- info$is_verified
    ## Record to notify about components extending a base license which
    ## permits extensions.
    if(length(extensions <- info$extensions) &&
       any(ind <- extensions$extensible)) {
        out$extensions <- extensions$components[ind]
        out$pointers <-
            Filter(length,
                   lapply(info$pointers,
                          function(p) {
                              fp <- file.path(dir, p)
                              if(file_test("-f", fp)) {
                                  ## Should this use the package
                                  ## encoding?
                                  c(p, readLines(fp, warn = FALSE))
                              } else NULL
                          }))
    }

    out$Maintainer <- meta["Maintainer"]
    ## pick out 'display name'
    display <- gsub("<.*", "", as.vector(out$Maintainer))
    display <- sub("[[:space:]]+$", "",
                   sub("^[[:space:]]+", "", display, useBytes = TRUE),
                   useBytes = TRUE)
    ## RFC 5322 allows '.' in the display name, but 2822 did not.
    ## ',' separates email addresses.
    out$Maintainer_needs_quotes <-
        grepl("[,]", display, useBytes = TRUE) && !grepl('^".*"$', display, useBytes = TRUE)
    out$empty_Maintainer_name <- !nzchar(display)

    ver <- meta["Version"]
    if(is.na(ver))
        stop("Package has no 'Version' field", call. = FALSE)
    if(grepl("(^|[.-])0[0-9]+", ver))
        out$version_with_leading_zeroes <- ver

    language <- meta["Language"]
    if((is.na(language) || language == "en") &&
       config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_USE_ASPELL_",
                                        FALSE))) {
        ignore <- c("[ \t]'[^']*'[ \t[:punct:]]",
                    "[ \t][[:alnum:]_.]*\\(\\)[ \t[:punct:]]")
        a <- utils:::aspell_package_description(dir,
                                                ignore = ignore,
                                                control =
                                                 c("--master=en_US",
                                                   "--add-extra-dicts=en_GB"),
                                                program = "aspell",
                                                dictionaries = "en_stats")
        if(NROW(a))
            out$spelling <- a
    }

    urls <- .get_standard_repository_URLs()

    parse_description_field <- function(desc, field, default = TRUE)
    {
        tmp <- desc[field]
        if (is.na(tmp)) default
        else switch(tmp,
                    "yes"=, "Yes" =, "true" =, "True" =, "TRUE" = TRUE,
                    "no" =, "No" =, "false" =, "False" =, "FALSE" = FALSE,
                    default)
    }

    ## If a package has a FOSS license, check whether any of its strong
    ## recursive dependencies restricts use.
    if(foss) {
        available <-
            utils::available.packages(utils::contrib.url(urls, "source"),
                                      filters =
                                      c("R_version", "duplicates"))
        ## We need the current dependencies of the package (so batch
        ## upload checks will not necessarily do "the right thing").
        package <- meta["Package"]
        depends <- c("Depends", "Imports", "LinkingTo")
        ## Need to be careful when merging the dependencies of the
        ## package (in case it is not yet available).
        if(!is.na(pos <- match(package, rownames(available)))) {
            available[package, depends] <- meta[depends]
        } else {
            entry <- rbind(meta[colnames(available)])
            rownames(entry) <- package
            available <- rbind(available, entry)
        }
        ldb <- analyze_licenses(available[, "License"], available)
        depends <- unlist(package_dependencies(package, available,
                                               recursive = TRUE))
        ru <- ldb$restricts_use
        pnames_restricts_use_TRUE <- rownames(available)[!is.na(ru) & ru]
        pnames_restricts_use_NA <- rownames(available)[is.na(ru)]
        bad <- intersect(depends, pnames_restricts_use_TRUE)
        if(length(bad))
            out$depends_with_restricts_use_TRUE <- bad
        bad <- intersect(depends, pnames_restricts_use_NA)
        if(length(bad))
            out$depends_with_restricts_use_NA <- bad
        bv <- parse_description_field(meta, "BuildVignettes", TRUE)
        if (!bv) out$foss_with_BuildVignettes <- TRUE
    }

    ## Check for possibly mis-spelled field names.
    nms <- names(meta)
    stdNms <- .get_standard_DESCRIPTION_fields()
    nms <- nms[is.na(match(nms, stdNms)) &
               !grepl("^(X-CRAN|Repository/R-Forge)", nms)]
    if(length(nms) && ## Allow maintainer notes  <stdName>Note :
       length(nms <- nms[is.na(match(nms, paste0(stdNms,"Note")))]))
        out$fields <- nms

    ## We do not want to use utils::available.packages() for now, as
    ## this unconditionally filters according to R version and OS type.
    ## <FIXME>
    ## This is no longer true ...
    ## </FIXME>
    .repository_db <- function(u) {
        con <- gzcon(url(sprintf("%s/src/contrib/PACKAGES.gz", u), "rb"))
        on.exit(close(con))
        ## hopefully all these fields are ASCII, or we need to re-encode.
        cbind(read.dcf(con,
                       c(.get_standard_repository_db_fields(), "Path")),
              Repository = u)

    }
    db <- tryCatch(lapply(urls, .repository_db), error = identity)
    if(inherits(db, "error")) {
        message("NB: need Internet access to use CRAN incoming checks")
        ## Actually, all repositories could be local file:// mirrors.
        return(out)
    }
    db <- do.call(rbind, db)

    ## Note that .get_standard_repository_URLs() puts the CRAN master first.
    CRAN <- urls[1L]

    ## Check for CRAN repository db overrides and possible conflicts.
    con <- url(sprintf("%s/src/contrib/PACKAGES.in", CRAN))
    odb <- read.dcf(con)
    close(con)
    ## For now (2012-11-28), PACKAGES.in is all ASCII, so there is no
    ## need to re-encode.  Eventually, it might be in UTF-8 ...
    entry <- odb[odb[, "Package"] == meta["Package"], ]
    entry <- entry[!is.na(entry) & (names(entry) != "Package")]
    if(length(entry)) {
        ## Check for conflicts between package license implications and
        ## repository overrides.  Note that the license info predicates
        ## are logicals (TRUE, NA or FALSE) and the repository overrides
        ## are character ("yes", missing or "no").
        if(!is.na(iif <- info$is_FOSS) &&
           !is.na(lif <- entry["License_is_FOSS"]) &&
           ((lif == "yes") != iif))
            out$conflict_in_license_is_FOSS <- lif
        if(!is.na(iru <- info$restricts_use) &&
           !is.na(lru <- entry["License_restricts_use"]) &&
           ((lru == "yes") != iru))
            out$conflict_in_license_restricts_use <- lru

        fmt <- function(s)
            unlist(lapply(s,
                          function(e) {
                              paste(strwrap(e, indent = 2L, exdent = 4L),
                                    collapse = "\n")
                          }))
        nms <- names(entry)
        ## Report all overrides for visual inspection.
        entry <- fmt(sprintf("  %s: %s", nms, entry))
        names(entry) <- nms
        out$overrides <- entry
        fields <- intersect(names(meta), nms)
        if(length(fields)) {
            ## Find fields where package metadata and repository
            ## overrides are in conflict.
            ind <- ! unlist(Map(identical,
                                fmt(sprintf("  %s: %s", fields, meta[fields])),
                                entry[fields]))
            if(any(ind))
                out$conflicts <- fields[ind]
        }
    }

    ## For now, information about the CRAN package archive is provided
    ## in CRAN's src/contrib/Meta/archive.rds.
    con <- gzcon(url(sprintf("%s/src/contrib/Meta/archive.rds", CRAN),
                     "rb"))
    CRAN_archive_db <- readRDS(con)
    close(con)
    packages_in_CRAN_archive <- names(CRAN_archive_db)

    ## Package names must be unique within standard repositories when
    ## ignoring case.
    package <- meta["Package"]
    packages <- db[, "Package"]
    if(! package %in% packages) out$new_submission <- TRUE
    clashes <- character()
    pos <- which((tolower(packages) == tolower(package)) &
                 (packages != package))
    if(length(pos))
        clashes <-
            sprintf("%s [%s]", packages[pos], db[pos, "Repository"])
    ## If possible, also catch clashes with archived CRAN packages
    ## (which might get un-archived eventually).
    if(length(packages_in_CRAN_archive)) {
        pos <- which((tolower(packages_in_CRAN_archive) ==
                      tolower(package)) &
                     (packages_in_CRAN_archive != package))
        if(length(pos)) {
            clashes <-
                c(clashes,
                  sprintf("%s [CRAN archive]",
                          packages_in_CRAN_archive[pos]))
        }
    }
    if(length(clashes))
        out$bad_package <- list(package, clashes)

    ## Is this duplicated from another repository?
    repositories <- db[(packages == package) &
                       (db[, "Repository"] != CRAN),
                       "Repository"]
    if(length(repositories))
        out$repositories <- repositories

    uses <- character()
    BUGS <- character()
    for (field in c("Depends", "Imports", "Suggests")) {
        p <- strsplit(meta[field], " *, *")[[1L]]
        p2 <- grep("^(multicore|snow|igraph0)( |\\(|$)", p, value = TRUE)
        uses <- c(uses, p2)
        p2 <- grep("^(BRugs|R2OpenBUGS|R2WinBUGS)( |\\(|$)", p, value = TRUE)
        BUGS <- c(BUGS, p2)
    }
    if (length(uses)) out$uses <- sort(unique(uses))
    if (length(BUGS)) out$BUGS <- sort(unique(BUGS))

    ## Check for non-Sweave vignettes (as indicated by the presence of a
    ## 'VignetteBuilder' field in DESCRIPTION) without
    ## 'build/vignette.rds'.

    vds <- character()
    if(!is.na(meta["VignetteBuilder"])) {
        if(!file.exists(vds <- file.path(dir, "build", "vignette.rds")))
            out$missing_vignette_index <- TRUE
        else
            vds <- readRDS(vds)[, "File"]
    }

    ## Check for vignette source (only) in old-style 'inst/doc' rather
    ## than 'vignettes'.
    vign_dir <- file.path(dir, "vignettes")
    if(length(vds)) {
        sources <- setdiff(list.files(file.path(dir, "inst", "doc")),
                           list.files(vign_dir))
        sources <- intersect(vds, sources)
    } else {
        pattern <- vignetteEngine("Sweave")$pattern
        sources <- setdiff(list.files(file.path(dir, "inst", "doc"),
                                      pattern = pattern),
                           list.files(vign_dir, pattern = pattern))
    }

    if(length(sources)) {
        out$have_vignettes_dir <- file_test("-d", vign_dir)
        out$vignette_sources_only_in_inst_doc <- sources
    }

    ## Is this an update for a package already on CRAN?
    db <- db[(packages == package) &
             (db[, "Repository"] == CRAN) &
             is.na(db[, "Path"]), , drop = FALSE]
    ## This drops packages in version-specific subdirectories.
    ## It also does not know about archived versions.
    if(!NROW(db)) {
        if(package %in% packages_in_CRAN_archive) {
            out$CRAN_archive <- TRUE
            v_m <- package_version(meta["Version"])
            v_a <- sub("^.*_(.*)\\.tar.gz$", "\\1",
                       basename(rownames(CRAN_archive_db[[package]])))
            v_a <- max(package_version(v_a, strict = FALSE),
                       na.rm = TRUE)
            if(v_m <= v_a)
                out$bad_version <- list(v_m, v_a)
        }
        if(!foss)
            out$bad_license <- meta["License"]
        return(out)
    }

    ## Checks from this point down should be for a package already on CRAN

    ## For now, there should be no duplicates ...

    ## Package versions should be newer than what we already have on CRAN.

    v_m <- package_version(meta["Version"])
    v_d <- max(package_version(db[, "Version"]))
    if((v_m <= v_d) &&
       !config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_SKIP_VERSIONS_",
                                         FALSE)))
        out$bad_version <- list(v_m, v_d)
    if((v_m$major == v_d$major) & (v_m$minor >= v_d$minor + 10))
        out$version_with_jump_in_minor <- list(v_m, v_d)

    ## Check submission recency and frequency.
    con <- gzcon(url(sprintf("%s/src/contrib/Meta/current.rds", CRAN),
                     "rb"))
    CRAN_current_db <- readRDS(con)
    close(con)
    mtimes <- c(CRAN_current_db[match(package,
                                      sub("_.*", "",
                                          rownames(CRAN_current_db)),
                                      nomatch = 0L),
                                "mtime"],
                CRAN_archive_db[[package]]$mtime)
    if(length(mtimes)) {
        deltas <- Sys.Date() - as.Date(sort(mtimes, decreasing = TRUE))
        ## Number of days since last update.
        recency <- as.numeric(deltas[1L])
        if(recency < 7)
            out$recency <- recency
        ## Number of updates in past 6 months.
        frequency <- sum(deltas <= 180)
        if(frequency > 6)
            out$frequency <- frequency
    }

    ## Watch out for maintainer changes.
    ## Note that we cannot get the maintainer info from the PACKAGES
    ## files.
    con <- gzcon(url(sprintf("%s/web/packages/packages.rds", CRAN), "rb"))
    db <- tryCatch(readRDS(con), error = identity)
    close(con)
    if(inherits(db, "error")) return(out)

    m_m <- as.vector(meta["Maintainer"]) # drop name
    m_d <- db[db[, "Package"] == package, "Maintainer"]
    # There may be white space differences here
    m_m_1 <- gsub("[[:space:]]+", " ", m_m)
    m_d_1 <- gsub("[[:space:]]+", " ", m_d)
    if(!all(m_m_1== m_d_1)) {
        ## strwrap is used below, so we need to worry about encodings.
        ## m_d is in UTF-8 already
        if(Encoding(m_m) == "latin1") m_m <- iconv(m_m, "latin1")
        out$new_maintainer <- list(m_m, m_d)
    }

    l_d <- db[db[, "Package"] == package, "License"]
    if(!foss && analyze_license(l_d)$is_verified)
        out$new_license <- list(meta["License"], l_d)

    out
}

format.check_package_CRAN_incoming <-
function(x, ...)
{
    c(character(),
      if(length(x$Maintainer))
          sprintf("Maintainer: %s", sQuote(paste(x$Maintainer, collapse = " ")))
      else "No maintainer field in DESCRIPTION file",
      if(x$empty_Maintainer_name)
          'The maintainer field lacks a name',
      if(x$Maintainer_needs_quotes)
          'The display-name part of the maintainer field should be enclosed in ""',
      if(length(x$new_submission))
          "New submission",
      if(length(y <- x$bad_package))
          sprintf("Conflicting package names (submitted: %s, existing: %s)",
                  y[[1L]], y[[2L]]),
      if(length(y <- x$repositories))
          sprintf("Package duplicated from %s", y),
      if(length(y <- x$CRAN_archive))
          "Package was archived on CRAN",
      if(length(y <- x$bad_version))
          sprintf("Insufficient package version (submitted: %s, existing: %s)",
                  y[[1L]], y[[2L]]),
      if(length(y <- x$version_with_leading_zeroes))
          sprintf("Version contains leading zeroes (%s)", y),
      if(length(y <- x$version_with_jump_in_minor))
          sprintf("Version jumps in minor (submitted: %s, existing: %s)",
                  y[[1L]], y[[2L]]),
      if(length(y <- x$recency))
          sprintf("Days since last update: %d", y),
      if(length(y <- x$frequency))
          sprintf("Number of updates in past 6 months: %d", y),
      if(length(y <- x$new_maintainer))
          c("New maintainer:",
            strwrap(y[[1L]], indent = 2L, exdent = 4L),
            "Old maintainer(s):",
            strwrap(y[[2L]], indent = 2L, exdent = 4L)),
      if(length(y <- x$bad_license))
          sprintf("Non-FOSS package license (%s)", y),
      if(length(y <- x$new_license))
          c("Change to non-FOSS package license.",
            "New license:",
            strwrap(y[[1L]], indent = 2L, exdent = 4L),
            "Old license:",
            strwrap(y[[2L]], indent = 2L, exdent = 4L)),
      if(length(y <- x$extensions)) {
          c("Components with restrictions and base license permitting such:",
            paste(" ", y),
            unlist(lapply(x$pointers,
                          function(e) {
                              c(sprintf("File '%s':", e[1L]),
                                paste(" ", e[-1L]))
                          })))
      },
      if(NROW(y <- x$spelling)) {
          s <- split(sprintf("%d:%d", y$Line, y$Column), y$Original)
          c("Possibly mis-spelled words in DESCRIPTION:",
            sprintf("  %s (%s)",
                    names(s),
                    lapply(s, paste, collapse = ", ")))
      },
      if(identical(x$foss_with_BuildVignettes, TRUE)) {
          "FOSS licence with BuildVignettes: false"
      },
      if(length(y <- x$fields)) {
          c("Possibly mis-spelled fields in DESCRIPTION:",
            sprintf("  %s", paste(sQuote(y), collapse = " ")))
      },
      if(length(y <- x$overrides)) {
          c("CRAN repository db overrides:", y)
      },
      if(length(y <- x$conflicts)) {
          sprintf("CRAN repository db conflicts: %s",
                  sQuote(y))
      },
      if(length(y <- x$conflict_in_license_is_FOSS)) {
          sprintf("Package license conflicts with %s override",
                  sQuote(paste("License_is_FOSS:", y)))
      },
      if(length(y <- x$conflict_in_license_restricts_use)) {
          sprintf("Package license conflicts with %s override",
                  sQuote(paste("License_restricts_use:", y)))
      },
      if(length(y <- x$depends_with_restricts_use_TRUE)) {
          c("Package has a FOSS license but eventually depends on the following",
	    if(length(y) > 1L)
	    "packages which restrict use:" else
	    "package which restricts use:",
            strwrap(paste(y, collapse = ", "), indent = 2L, exdent = 4L))
      },
      if(length(y <- x$depends_with_restricts_use_NA)) {
          c("Package has a FOSS license but eventually depends on the following",
	    if(length(y) > 1L)
            "packages which may restrict use:" else
	    "package which may restrict use:",
            strwrap(paste(y, collapse = ", "), indent = 2L, exdent = 4L))
      },
      if (length(y <- x$uses)) {
          paste(if(length(y) > 1L)
		"Uses the superseded packages:" else
		"Uses the superseded package:",
                paste(sQuote(y), collapse = ", "))
      },
      if (length(y <- x$BUGS)) {
          paste(if(length(y) > 1L)
		"Uses the non-portable packages:" else
		"Uses the non-portable package:",
                paste(sQuote(y), collapse = ", "))
      },
      if(length(y <- x$vignette_sources_only_in_inst_doc)) {
          if(identical(x$have_vignettes_dir, FALSE))
              c("Vignette sources in 'inst/doc' with no 'vignettes' directory:",
                strwrap(paste(sQuote(y), collapse = ", "),
                        indent = 2L, exdent = 2L),
                "A 'vignettes' directory is required as from R 3.1.0")
          else
              c("Vignette sources in 'inst/doc' missing from the 'vignettes' directory:",
                strwrap(paste(sQuote(y), collapse = ", "),
                        indent = 2L, exdent = 2L))
      },
      if(length(y <- x$missing_vignette_index)) {
          "Package has a VignetteBuilder field but no prebuilt vignette index."
      }
      )
}

### * .check_Rd_metadata

.check_Rd_metadata <-
function(package, dir, lib.loc = NULL)
{
    ## Perform package-level Rd metadata checks:
    ## names and aliases must be unique within a package.

    ## Note that we cannot use Rd_aliases(), as this does
    ##   if(length(aliases))
    ##       sort(unique(unlist(aliases, use.names = FALSE)))

    out <- structure(list(), class = "check_Rd_metadata")

    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        dir <- find.package(package, lib.loc)
        rds <- file.path(dir, "Meta", "Rd.rds")
        if(file_test("-f", rds)) {
            meta <- readRDS(rds)
            files <- meta$File
            names <- meta$Name
            aliases <- meta$Aliases
        } else {
            return(out)
        }
    } else {
        if(file_test("-d", file.path(dir, "man"))) {
            db <- Rd_db(dir = dir)
            files <- basename(names(db))
            names <- sapply(db, .Rd_get_metadata, "name")
            aliases <- lapply(db, .Rd_get_metadata, "alias")
        } else {
            return(out)
        }
    }

    ## <FIXME>
    ## Remove eventually, as .Rd_get_metadata() and hence Rd_info() now
    ## eliminate duplicated entries ...
    aliases <- lapply(aliases, unique)
    ## </FIXME>

    files_grouped_by_names <- split(files, names)
    files_with_duplicated_names <-
        files_grouped_by_names[sapply(files_grouped_by_names,
                                      length) > 1L]
    if(length(files_with_duplicated_names))
        out$files_with_duplicated_names <-
            files_with_duplicated_names

    files_grouped_by_aliases <-
        split(rep.int(files, sapply(aliases, length)),
              unlist(aliases, use.names = FALSE))
    files_with_duplicated_aliases <-
        files_grouped_by_aliases[sapply(files_grouped_by_aliases,
                                      length) > 1L]
    if(length(files_with_duplicated_aliases))
        out$files_with_duplicated_aliases <-
            files_with_duplicated_aliases

    out
}

format.check_Rd_metadata <-
function(x, ...)
{
    c(character(),
      if(length(bad <- x$files_with_duplicated_name)) {
          unlist(lapply(names(bad),
                 function(nm) {
                     c(gettextf("Rd files with duplicated name '%s':",
                                nm),
                       .pretty_format(bad[[nm]]))
                 }))
      },
      if(length(bad <- x$files_with_duplicated_aliases)) {
          unlist(lapply(names(bad),
                 function(nm) {
                     c(gettextf("Rd files with duplicated alias '%s':",
                                nm),
                       .pretty_format(bad[[nm]]))
                 }))
      })
}

## * .check_Rd_contents

.check_Rd_contents <-
function(package, dir, lib.loc = NULL)
{
    out <- list()
    class(out) <- "check_Rd_contents"

    ## Argument handling.
    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        dir <- find.package(package, lib.loc)
        ## Using package installed in @code{dir} ...
    }
    else {
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        ## Using sources from directory @code{dir} ...
        if(!file_test("-d", dir))
            stop(gettextf("directory '%s' does not exist", dir),
                 domain = NA)
        else
            dir <- file_path_as_absolute(dir)
    }

    db <- if(!missing(package))
        Rd_db(package, lib.loc = dirname(dir))
    else
        Rd_db(dir = dir)

    names(db) <- .Rd_get_names_from_Rd_db(db)

    ## Exclude internal objects from further computations.
    ind <- sapply(lapply(db, .Rd_get_metadata, "keyword"),
                  function(x) length(grep("^ *internal *$", x)) > 0L )
    if(any(ind))                        # exclude them
        db <- db[!ind]

    check_offending_autogenerated_content <-
        !identical(as.logical(Sys.getenv("_R_CHECK_RD_CONTENTS_AUTO_")),
                   FALSE)
    offending_autogenerated_content <- NULL

    for(nm in names(db)) {
        rd <- db[[nm]]

        ## Arguments with no description.
        arg_table <- .Rd_get_argument_table(rd)
        arguments_with_no_description <-
            arg_table[grepl("^[[:blank:]]*$", arg_table[, 2L]),
                      1L]

        ## Autogenerated Rd content which needs editing.
        if(check_offending_autogenerated_content)
            offending_autogenerated_content <-
                .Rd_get_offending_autogenerated_content(rd)

        if(length(arguments_with_no_description)
           || length(offending_autogenerated_content)) {
            out[[nm]] <-
                list(arguments_with_no_description =
                     arguments_with_no_description,
                     offending_autogenerated_content =
                     offending_autogenerated_content)
        }
    }

    out
}

format.check_Rd_contents <-
function(x, ...)
{
    .fmt <- function(nm) {
        y <- x[[nm]]
        c(if(length(arguments_with_no_description <-
                    y[["arguments_with_no_description"]])) {
              c(gettextf("Argument items with no description in Rd object '%s':",
                         nm),
                .pretty_format(arguments_with_no_description))
          },
          if(length(offending_autogenerated_content <-
                    y[["offending_autogenerated_content"]])) {
              c(gettextf("Auto-generated content requiring editing in Rd object '%s':",
                         nm),
                sprintf("  %s", offending_autogenerated_content[, 1L]))
          },
          "")
    }

    as.character(unlist(lapply(names(x), .fmt)))
}

### * .check_Rd_line_widths

.check_Rd_line_widths <-
function(dir, limit = c(usage = 95, examples = 105), installed = FALSE)
{
    db <- if(installed)
        Rd_db(basename(dir), lib.loc = dirname(dir))
    else
        Rd_db(dir = dir)
    out <- find_wide_Rd_lines_in_Rd_db(db, limit)
    class(out) <- "check_Rd_line_widths"
    attr(out, "limit") <- limit
    out
}

format.check_Rd_line_widths <-
function(x, ...)
{
    if(!length(x)) return(character())

    .truncate <- function(s) {
        ifelse(nchar(s) > 140L,
               paste(substring(s, 1, 140L),
                     "... [TRUNCATED]"),
               s)
    }

    limit <- attr(x, "limit")
    ## Rd2txt() by default adds a section indent of 5 also incorporated
    ## in the limits used for checking.  But users actually look at the
    ## line widths in their source Rd file, so remove the indent when
    ## formatting for reporting check results.
    ## (This should reduce confusion as long as we only check the line
    ## widths in verbatim type sections.)
    limit <- limit - 5L

    sections <- names(limit)

    .fmt <- function(nm) {
        y <- x[[nm]]
        c(sprintf("Rd file '%s':", nm),
          unlist(lapply(sections,
                        function(s) {
                            lines <- y[[s]]
                            if(!length(lines)) character() else {
                                c(sprintf("  \\%s lines wider than %d characters:",
                                          s, limit[s]),
                                  .truncate(lines))
                            }
                        }),
                 use.names = FALSE),
          "")
    }

    as.character(unlist(lapply(names(x), .fmt)))
}

find_wide_Rd_lines_in_Rd_db <-
function(x, limit = NULL)
{
    y <- lapply(x, find_wide_Rd_lines_in_Rd_object, limit)
    Filter(length, y)
}

find_wide_Rd_lines_in_Rd_object <-
function(x, limit = NULL)
{
    if(is.null(limit))
        limit <- list(usage = c(79, 95), examples = c(87, 105))
    sections <- names(limit)
    if(is.null(sections))
        stop("no Rd sections specified")
    y <- Map(function(s, l) {
        out <- NULL
        zz <- textConnection("out", "w", local = TRUE)
        on.exit(close(zz))
        pos <- which(RdTags(x) == s)
        Rd2txt(x[pos[1L]], out = zz, fragment = TRUE)
        nc <- nchar(out)
        if(length(l) > 1L) {
            ind_warn <- (nc > max(l))
            ind_note <- (nc > min(l)) & !ind_warn
            Filter(length,
                   list(warn = out[ind_warn], note = out[ind_note]))
        } else {
            out[nc > l]
        }
    },
             paste0("\\", sections),
             limit)
    names(y) <- sections
    Filter(length, y)
}


### * .find_charset

.find_charset <-
function()
{
    l10n <- l10n_info()
    enc <- if(l10n[["UTF-8"]]) "UTF-8" else utils::localeToCharset()
    cat("charset: ", enc, "\n", sep = "")
    invisible()
}


### * Utilities

### ** as.alist.call

as.alist.call <-
function(x)
{
    y <- as.list(x)
    ind <- if(is.null(names(y)))
        seq_along(y)
    else
        which(names(y) == "")
    if(length(ind)) {
        names(y)[ind] <- sapply(y[ind], paste, collapse = " ")
        y[ind] <- rep.int(list(alist(irrelevant = )[[1L]]), length(ind))
    }
    y
}

### ** as.alist.symbol

as.alist.symbol <-
function(x)
{
    as.alist.call(call(as.character(x)))
}

### ** .arg_names_from_call

.arg_names_from_call <-
function(x)
{
    y <- as.character(x)
    if(!is.null(nx <- names(x))) {
        ind <- which(nx != "")
        y[ind] <- nx[ind]
    }
    y
}

### ** .dquote_method_markup

## See the notes below.
## An alternative and possibly more efficient implementation could be
## based using gregexpr(re, txt), massaging the matches and merging with
## the non-matched parts.

.dquote_method_markup <-
function(txt, re)
{
    out <- ""
    while((ipos <- regexpr(re, txt)) > -1L) {
        epos <- ipos + attr(ipos, "match.length") - 1L
        str <- substring(txt, ipos, epos)
        str <- sub("\"", "\\\"", str, fixed = TRUE)
        str <- sub("\\", "\\\\", str, fixed = TRUE)
        out <- sprintf("%s%s\"%s\"", out,
                       substring(txt, 1L, ipos - 1L), str)
        txt <- substring(txt, epos + 1L)
    }
    paste0(out, txt)
}

### ** .format_calls_in_file

.format_calls_in_file <-
function(calls, f)
{
    c(gettextf("File %s:", sQuote(f)),
      paste0("  ",
             unlist(lapply(calls,
                           function(e)
                           paste(deparse(e), collapse = "\n")))))
}

### ** .functions_to_be_ignored_from_usage

.functions_to_be_ignored_from_usage <-
function(package_name)
{
    c("<-", "=",
      if(package_name == "base")
      c("(", "{", "function", "if", "for", "while", "repeat",
        "Math", "Ops", "Summary", "Complex"),
      if(package_name == "utils") "?",
      if(package_name == "methods") "@")
}

### ** .functions_with_no_useful_S3_method_markup

## <FIXME>
## Remove eventually ...
.functions_with_no_useful_S3_method_markup <-
function()
{
    ## Once upon a time ... there was no useful markup for S3 methods
    ## for subscripting/subassigning and binary operators.

    c(if(identical(as.logical(Sys.getenv("_R_CHECK_RD_USAGE_METHOD_SUBSET_")),
                   FALSE))
      c("[", "[[", "$", "[<-", "[[<-", "$<-"),
      if(identical(as.logical(Sys.getenv("_R_CHECK_RD_USAGE_METHOD_BINOPS_")),
                   FALSE))
      c("+", "-", "*", "/", "^", "<", ">", "<=", ">=", "!=", "==", "%%",
        "%/%", "&", "|"),
      "!")
}
## </FIXME>

### ** get_S4_generics_with_methods

## FIXME: make option of methods::getGenerics()
## JMC agreed & proposed argument  'excludeEmpty = FALSE'
get_S4_generics_with_methods <-
function(env, verbose = getOption("verbose"))
{
    env <- as.environment(env)
    ##  Filter(function(g) methods::isGeneric(g, where = env),
    ##	       methods::getGenerics(env))
    r <- methods::getGenerics(env)
    if(length(r) && {
	hasM <- lapply(r, function(g)
		       tryCatch(methods::hasMethods(g, where = env),
				error = identity))
	if(any(hasErr <- sapply(hasM, inherits, what = "error"))) {
            dq <- function(ch) paste0('"', ch ,'"')
            rErr <- r[hasErr]
            pkgs <- r@package[hasErr]
            ## FIXME: This warning should not happen here when called
            ## from R CMD check, but rather be part of a new "check"
            ## there !
	    warning(gettextf("Generics 'g' in 'env' %s where '%s' errors: %s\nMay need something like\n\n%s\nin NAMESPACE.",
                             format(env),
                             "hasMethods(g, env)",
                             paste(sQuote(rErr), collapse = ", "),
                             paste0("  importFrom(",
                                    paste(dq(pkgs), dq(rErr), sep =", "),
                                    ")\n")
                             ),
                    domain = NA)
	    hasM <- hasM[!hasErr]
	}
	!all(ok <- unlist(hasM))
    }) {
	if(verbose)
            message(sprintf(ngettext(sum(!ok),
                                     "Generic without any methods in %s: %s",
                                     "Generics without any methods in %s: %s"),
                            format(env),
                            paste(sQuote(r[!ok]), collapse = ", ")),
                    domain = NA)
	r[ok]
    }
    else as.vector(r)# for back-compatibility and current ..../tests/reg-S4.R
}

### ** .get_S4_generics

## For several QC tasks, we need to compute on "all S4 methods in/from a
## package".  These days, this can straightforwardly be accomplished by
## looking at all methods tables in the package environment or namespace.
## Somewhat historically, we organize our computations by first using
## using methods::getGenerics() to find all S4 generics the package has
## methods for, and then iterating over these.  To make this work
## conveniently, we wrap around methods::getGenerics() to rewrite its
## "ObjectsWithPackage" result into a (currently unclassed) list of
## generic-name-with-package-name-attribute objects, and wrap around
## methods::findMethods() to perform lookup based on this information
## (rather than the genericFunction object itself), and also rewrite the
## MethodsList result into a simple list.

.get_S4_generics <-
function(env)
{
    env <- as.environment(env)
    g <- methods::getGenerics(env)
    Map(function(f, p) {
            attr(f, "package") <- p
            f
        },
        g@.Data,
        g@package)
}

### ** .get_S4_methods_list

.get_S4_methods_list <-
function(f, env)
{
    ## Get S4 methods in environment env for f a structure with the name
    ## of the S4 generic and its package in the corresponding attribute.

    ## For the QC computations, we really only want the S4 methods
    ## defined in a package, so we try to exclude derived default
    ## methods as well as methods inherited from other environments.

    env <- as.environment(env)

    ## <FIXME>
    ## Use methods::findMethods() once this gets a package argument.
    ## This will return a listOfMethods object: turn this into a simple
    ## list of methods named by hash-collapsed signatures.
    tab <- get(methods:::.TableMetaName(f, attr(f, "package")), envir = env)
    nms <- objects(tab, all.names = TRUE)
    mlist <- lapply(nms, get, envir = tab)
    names(mlist) <- nms
    ## </FIXME>

    ## First, derived default methods (signature w/ "ANY").
    if(any(ind <- as.logical(sapply(mlist, methods::is,
				    "derivedDefaultMethod"))))
	mlist <- mlist[!ind]

    if(length(mlist)) {
        ## Determining the methods defined in a package from the package
        ## env or the associated namespace seems rather tricky.  What we
        ## seem to observe is the following.
        ## * If there is a namespace N, methods defined in the package
        ##   have N as their environment, for both the package env and
        ##   the associated namespace.
        ## * If there is no namespace, methods defined in the package
        ##   have an environment E which is empty and has globalenv() as
        ##   its parent.  (If the package defines generics, these seem
        ##   to have E as their parent env.)
        ## However, in the latter case, there seems no way to infer E
        ## from the package env.  In the old days predating methods
        ## tables, we compared methods in the package env with those in
        ## its parent env, and excluded the ones already found there.
        ## This no longer works, so we exclude "at least" all methods
        ## with a namespace environment (as these cannot come from a
        ## package with no namespace).

        namespace <- if(isNamespace(env)) env else .get_namespace_from_package_env(env)
        mlist <- if(!is.null(namespace))
            Filter(function(m) identical(environment(m), namespace), mlist)
        else
            Filter(function(m) environmentName(environment(m)) == "", mlist)
    }

    mlist
}

.get_ref_classes <-
function(env)
{
    env <- as.environment(env)
    cl <- methods::getClasses(env)
    cl <- cl[unlist(lapply(cl, function(Class) methods::is(methods::getClass(Class, where = env), "refClassRepresentation")))]
    if(length(cl)) {
        res <- lapply(cl, function(Class) {
            def <- methods::getClass(Class, where = env)
            ff <- def@fieldPrototypes
            accs <- unlist(lapply(ff, function(what) methods::is(what, "activeBindingFunction") && !methods::is(what, "defaultBindingFunction")))
            c(as.list(def@refMethods), as.list(ff)[accs])
        })
        names(res) <- cl
        res
    } else list()
}

.get_namespace_from_package_env <-
function(env)
{
    package <-
        sub(".*:([^_]*).*", "\\1", attr(env, "name", exact = TRUE))
    if(length(package) && nzchar(package)) .getNamespace(as.name(package))
}


### ** .is_call_from_replacement_function_usage

.is_call_from_replacement_function_usage <-
function(x)
{
    ((length(x) == 3L)
     && (identical(x[[1L]], as.symbol("<-")))
     && (length(x[[2L]]) > 1L)
     && is.symbol(x[[3L]]))
}

### ** .make_siglist

.make_siglist <-
function(x)
{
    ## Argument 'x' should be a named list of methods as obtained by
    ## methods::findMethods() or .get_S4_methods_list().
    gsub("#", ",", names(x), fixed = TRUE)
}

### ** .make_signatures

.make_signatures <-
function(cls)
{
    ## Note that (thanks JMC), when comparing signatures, the signature
    ## has to be stripped of trailing "ANY" elements (which are always
    ## implicit) or padded to a fixed length.
    sub("(#ANY)*$", "", unlist(lapply(cls, paste, collapse = "#")))
}

### ** .massage_file_parse_error_message

.massage_file_parse_error_message <-
function(x)
    sub("^[^:]+:[[:space:]]*", "", x)

### ** .package_env

.package_env <-
function(package_name)
{
    as.environment(paste("package", package_name, sep = ":"))
}

### ** .parse_text_as_much_as_possible

.parse_text_as_much_as_possible <-
function(txt)
{
    exprs <- tryCatch(parse(text = txt), error = identity)
    if(!inherits(exprs, "error")) return(exprs)
    exprs <- expression()
    lines <- unlist(strsplit(txt, "\n"))
    bad_lines <- character()
    while((n <- length(lines))) {
        i <- 1L; txt <- lines[1L]
        while(inherits(yy <- tryCatch(parse(text = txt),
                                      error = identity),
                       "error")
              && (i < n)) {
            i <- i + 1L; txt <- paste(txt, lines[i], collapse = "\n")
        }
        if(inherits(yy, "error")) {
            bad_lines <- c(bad_lines, lines[1L])
            lines <- lines[-1L]
        }
        else {
            exprs <- c(exprs, yy)
            lines <- lines[-seq_len(i)]
        }
    }
    attr(exprs, "bad_lines") <- bad_lines
    exprs
}

### ** .parse_usage_as_much_as_possible

.parse_usage_as_much_as_possible <-
function(x)
{
    if(!length(x)) return(expression())
    ## Drop specials and comments.
    ## <FIXME>
    ## Remove calling .Rd_drop_comments() eventually.
    x <- .Rd_drop_comments(x)
    ## </FIXME>
    txt <- .Rd_deparse(.Rd_drop_nodes_with_tags(x, "\\special"),
                       tag = FALSE)
    txt <- gsub("\\\\l?dots", "...", txt)
    txt <- .dquote_method_markup(txt, .S3_method_markup_regexp)
    txt <- .dquote_method_markup(txt, .S4_method_markup_regexp)
    ## Transform <<see below>> style markup so that we can catch and
    ## throw it, rather than "basically ignore" it by putting it in the
    ## bad_lines attribute.
    txt <- gsub("(<<?see below>>?)", "`\\1`", txt)
    ## \usage is only 'verbatim-like'
    ## <FIXME>
    ## 'LanguageClasses.Rd' in package methods has '"\{"' in its usage.
    ## But why should it use the backslash escape?
    txt <- gsub("\\{", "{", txt, fixed = TRUE)
    txt <- gsub("\\}", "}", txt, fixed = TRUE)
    ## </FIXME>
    ## now any valid escape by \ is
    ##   \a \b \f \n \r \t \u \U \v \x \' \" \\ or \octal
    txt <- gsub("(^|[^\\])\\\\($|[^abfnrtuUvx0-9'\"\\])",
                "\\1<unescaped bksl>\\2", txt)
    ## and since this may overlap, try again
    txt <- gsub("(^|[^\\])\\\\($|[^abfnrtuUvx0-9'\"\\])",
                "\\1<unescaped bksl>\\2", txt)
    .parse_text_as_much_as_possible(txt)
}

### ** .pretty_format

.pretty_format <-
function(x)
{
    strwrap(paste(sQuote(x), collapse = " "),
            indent = 2L, exdent = 2L)
}
.pretty_format2 <-
function(msg, x)
{
    xx <- strwrap(paste(sQuote(x), collapse = " "), exdent = 2L)
    if (length(xx) > 1L || (nchar(msg) + nchar(xx) + 1L > 75L))
        c(msg, .pretty_format(x))
    else paste(msg, xx, sep = " ")
}

### ** .pretty_print

.pretty_print <-
function(x)
{
    writeLines(strwrap(paste(x, collapse = " "),
                       indent = 2L, exdent = 2L))
}

### ** .strip_backticks

.strip_backticks <-
function(x)
    gsub("`", "", x)

### ** .transform_S3_method_markup

.transform_S3_method_markup <-
function(x)
{
    ## Note how we deal with S3 replacement methods found.
    ## These come out named "\method{GENERIC}{CLASS}<-" which we
    ## need to turn into 'GENERIC<-.CLASS'.
    re <- sprintf("%s(<-)?", .S3_method_markup_regexp)
    ## Note that this is really only called on "function" names obtained
    ## by parsing the \usage texts, so that the method regexps possibly
    ## augmented by '<-' fully match if they match.
    ## We should be able to safely strip all backticks; alternatively,
    ## we could do something like
    ##   cl <- .strip_backticks(sub(re, "\\4", x))
    ##   sub(re, sprintf("\\3\\5.%s", cl), x)
    .strip_backticks(sub(re, "\\3\\5.\\4", x))
}

### ** .transform_S4_method_markup

.transform_S4_method_markup <-
function(x)
{
    re <- sprintf("%s(<-)?", .S4_method_markup_regexp)
    ## We should be able to safely strip all backticks; alternatively,
    ## we could do something like
    ##   sl <- .strip_backticks(sub(re, "\\3", x))
    ##   sub(re, sprintf("\\\\S4method{\\2\\7}{%s}", sl), x)
    .strip_backticks(sub(re, "\\\\S4method{\\2\\7}{\\3}", x))
}

### ** .S3_method_markup_regexp

## For matching \(S3)?method{GENERIC}{CLASS}.
## GENERIC can be
## * a syntactically valid name
## * one of $ [ [[
## * one of the binary operators
##   + - * / ^ < <= > >= != == | & %something%
## (as supported by Rdconv).
## See also .functions_with_no_useful_S3_method_markup.
## CLASS can be a syntactic name (we could be more precise about the
## fact that these must start with a letter or '.'), or anything quoted
## by backticks (not containing backticks itself for now).  Arguably,
## non-syntactic class names should best be avoided, but R has always
## had them at least for
## R> class(bquote({.}))
## [1] "{"
## R> class(bquote((.)))
## [1] "("

## <NOTE>
## Handling S3/S4 method markup is somewhat tricky.
## When using R to parse the usage entries, we turn the
##   \METHOD{GENERIC}{CLASS_OR_SIGLIST}(args)
## markup into (something which parses to) a function call by suitably
## quoting the \METHOD{GENERIC}{CLASS_OR_SIGLIST} part.  In case of a
## replacement method
##   \METHOD{GENERIC}{CLASS_OR_SIGLIST}(args) <- value
## parsing results in a
##   \METHOD{GENERIC}{CLASS_OR_SIGLIST}<-
## pseudo name, which need to be transformed to
##   \METHOD{GENERIC<-}{CLASS_OR_SIGLIST}
## We currently use double quoting for the parse step.  As we also allow
## for non-syntactic class names quoted by backticks, this means that
## double quotes and backslashes need to be escaped.  Alternatively, we
## could strip backticks right away and quote by backticks, but then the
## replacement method transformation would need different regexps.
## </NOTE>

.S3_method_markup_regexp <-
    sprintf("(\\\\(S3)?method\\{(%s)\\}\\{(%s)\\})",
            paste(c("[._[:alnum:]]*",
                    ## Subscripting
                    "\\$", "\\[\\[?",
                    ## Binary operators and unary '!'.
                    "\\+", "\\-", "\\*", "\\/", "\\^",
                    "<=?", ">=?", "!=?", "==", "\\&", "\\|",
                    "\\%[[:alnum:][:punct:]]*\\%"),
                  collapse = "|"),
            "[._[:alnum:]]+|`[^`]+`")

### ** .S4_method_markup_regexp

## For matching \S4method{GENERIC}{SIGLIST}.
## SIGLIST can be a comma separated list of CLASS specs as above.

.S4_method_markup_regexp <-
    sprintf("(\\\\S4method\\{(%s)\\}\\{(%s)\\})",
            paste(c("[._[:alnum:]]*",
                    ## Subscripting
                    "\\$", "\\[\\[?",
                    ## Binary operators and unary '!'.
                    "\\+", "\\-", "\\*", "\\/", "\\^",
                    "<=?", ">=?", "!=?", "==", "\\&", "\\|",
                    "\\%[[:alnum:][:punct:]]*\\%"),
                  collapse = "|"),
            "(([._[:alnum:]]+|`[^`]+`),)*([._[:alnum:]]+|`[^`]+`)")

### ** .valid_maintainer_field_regexp

.make_RFC_2822_email_address_regexp <-
function()
{
    ## Local part consists of ASCII letters and digits, the characters
    ##   ! # $ % * / ? | ^ { } ` ~ & ' + = _ -
    ## and . provided it is not leading or trailing or repeated, or must
    ## be a quoted string.
    ## Domain part consists of dot-separated elements consisting of
    ## ASCII letters, digits and hyphen.
    ## We could also check that the local and domain parts are no longer
    ## than 64 and 255 characters, respectively.
    ## See http://en.wikipedia.org/wiki/Email_address.
    ASCII_letters_and_digits <-
        "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
    l <- sprintf("[%s%s]", ASCII_letters_and_digits, "!#$%*/?|^{}`~&'+=_-")
    d <- sprintf("[%s%s]", ASCII_letters_and_digits, "-")
    ## Be careful to arrange the hyphens to come last in the range spec.
    sprintf("(\\\".+\\\"|(%s+\\.)*%s+)@(%s+\\.)*%s+", l, l, d, d)
}

.valid_maintainer_field_regexp <-
    sprintf("^[[:space:]]*(.*<%s>|ORPHANED)[[:space:]]*$",
            .make_RFC_2822_email_address_regexp())

### ** .Rd_get_offending_autogenerated_content

.Rd_get_offending_autogenerated_content <-
function(x)
{
    out <- NULL

    ## /data/rsync/PKGS/geoR/man/globalvar.Rd
    s <- .Rd_get_section(x, "title")
    if(length(s)) {
        s <- .Rd_deparse(s, tag = FALSE)
        if(.strip_whitespace(s) == "~~function to do ... ~~")
            out <- rbind(out, c("\\title", s))
    }
    s <- .Rd_get_section(x, "description")
    if(length(s)) {
        s <- .Rd_deparse(s, tag = FALSE)
        if(.strip_whitespace(s) ==
           "~~ A concise (1-5 lines) description of what the function does. ~~")
            out <- rbind(out, c("\\description", s))
    }
    s <- .Rd_get_section(x, "details")
    if(length(s)) {
        s <- .Rd_deparse(s, tag = FALSE)
        if(.strip_whitespace(s) ==
           "~~ If necessary, more details than the description above ~~")
            out <- rbind(out, c("\\details", s))
    }

    ## /data/rsync/PKGS/mimR/man/plot.Rd:\author{ ~~who you are~~ }
    s <- .Rd_get_section(x, "author")
    if(length(s)) {
        s <- .Rd_deparse(s, tag = FALSE)
        if(.strip_whitespace(s) == "~~who you are~~")
            out <- rbind(out, c("\\author", s))
    }
    ## /data/rsync/PKGS/mimR/man/mim-class.Rd:\note{ ~~further notes~~ }
    s <- .Rd_get_section(x, "note")
    if(length(s)) {
        s <- .Rd_deparse(s, tag = FALSE)
        if(.strip_whitespace(s) == "~~further notes~~")
            out <- rbind(out, c("\\note", s))
    }

    tab <- .Rd_get_argument_table(x)
    if(length(tab)) {
        ## /data/rsync/PKGS/Rmpfr/man/mpfrArray.Rd:
        ##   \item{precBits}{ ~~Describe \code{precBits} here~~ }
        descriptions <- .strip_whitespace(tab[, 2L])
        ind <- (descriptions ==
                sprintf("~~Describe \\code{%s} here~~", tab[, 1L]))
        if(any(ind))
            out <- rbind(out,
                         cbind(sprintf("\\arguments, description of item '%s'",
                                       tab[ind, 1L]),
                               tab[ind, 2L]))
    }

    ## <NOTE>
    ## Obviously, auto-generation does too much here, so maybe do not
    ## include these in production check code ...
    tab <- .Rd_get_methods_description_table(x)
    if(length(tab)) {
        descriptions <- .strip_whitespace(tab[, 2L])
        ## /data/rsync/PKGS/coin/man/initialize-methods.Rd
        ind <- descriptions == "~~describe this method here"
        if(any(ind))
            out <- rbind(out,
                         cbind(sprintf("section 'Methods', description of item '%s'",
                                       tab[ind, 1L]),
                               tab[ind, 2L]))
    }
    ## </NOTE>

    out
}


### Local variables: ***
### mode: outline-minor ***
### outline-regexp: "### [*]+" ***
### End: ***
#  File src/library/tools/R/Rd.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/

### * Rd_info

Rd_info <-
function(file, encoding = "unknown")
{
    ## <FIXME>
    ## This used to work only for a given Rd file.
    ## We now also allow for passing a parsed Rd object.
    ## Is the Rd file case still needed?

    if(inherits(file, "Rd")) {
        Rd <- file
        description <- attr(attr(Rd, "srcref"), "srcfile")$filename
    } else {
        if(is.character(file)) {
            file <- file(file)
            on.exit(close(file))
        }
        if(!inherits(file, "connection"))
            stop("argument 'file' must be a character string or connection")
        description <- summary(file)$description
        Rd <- prepare_Rd(file, encoding = encoding,
                         defines = .Platform$OS.type)
    }

    aliases <- .Rd_get_metadata(Rd, "alias")
    concepts <- .Rd_get_metadata(Rd, "concept")
    keywords <- .Rd_get_metadata(Rd, "keyword")

    ## Could be none or more than one ... argh.
    Rd_type <- .Rd_get_doc_type(Rd)
    encoding <- c(.Rd_get_metadata(Rd, "encoding"), "")[1L]

    Rd_name <- .Rd_get_name(Rd)
    if(!length(Rd_name)) {
        msg <-
            c(gettextf("missing/empty %s field in '%s'",
                       "\\name",
                       description),
              gettextf("Rd files must have a non-empty %s.",
                       "\\name"),
              gettext("See chapter 'Writing R documentation' in manual 'Writing R Extensions'."))
        stop(paste(msg, collapse = "\n"), domain = NA)
    }

    Rd_title <- .Rd_get_title(Rd)
    if(!nchar(Rd_title)) {
        msg <-
            c(gettextf("missing/empty \\title field in '%s'",
                       description),
              gettext("Rd files must have a non-empty \\title."),
              gettext("See chapter 'Writing R documentation' in manual 'Writing R Extensions'."))
        stop(paste(msg, collapse = "\n"), domain = NA)
    }

    list(name = Rd_name, type = Rd_type, title = Rd_title,
         aliases = aliases, concepts = concepts, keywords = keywords,
         encoding = encoding)
}

### * Rd_contents

Rd_contents <-
function(db)
{
    ## Compute contents db from Rd db.
    ## NB: Encoding is the encoding declared in the file, not
    ## that after parsing.
    if(!length(db)) {
        out <- data.frame(File = character(),
                          Name = character(),
                          Type = character(),
                          Title = character(),
                          Encoding = character(),
                          stringsAsFactors = FALSE)
        out$Aliases <- list()
        out$Concepts <- list()
        out$Keywords <- list()
        return(out)
    }

    entries <- c("Name", "Type", "Title", "Aliases", "Concepts",
                 "Keywords", "Encoding")
    contents <- vector("list", length(db) * length(entries))
    dim(contents) <- c(length(db), length(entries))
    for(i in seq_along(db)) {
        contents[i, ] <- Rd_info(db[[i]])
    }
    colnames(contents) <- entries

    title <- .Rd_format_title(unlist(contents[ , "Title"]))
    out <- data.frame(File = basename(names(db)),
                      Name = unlist(contents[ , "Name"]),
                      Type = unlist(contents[ , "Type"]),
                      Title = title,
                      Encoding = unlist(contents[ , "Encoding"]),
                      row.names = NULL, # avoid trying to compute row
                                        # names
                      stringsAsFactors = FALSE)
    out$Aliases <- contents[ , "Aliases"]
    out$Concepts <- contents[ , "Concepts"]
    out$Keywords <- contents[ , "Keywords"]
    out
}

### * .write_Rd_contents_as_RDS

.write_Rd_contents_as_RDS <-
function(contents, outFile)
{
    ## Save Rd contents db to @file{outFile}.

    ## <NOTE>
    ## To deal with possible changes in the format of the contents db
    ## in the future, use a version attribute and/or a formal class.
    saveRDS(contents, file = outFile, compress = TRUE)
    ## </NOTE>
}

### * .write_Rd_contents_as_DCF

if(FALSE) {
.write_Rd_contents_as_DCF <-
function(contents, packageName, outFile)
{
    ## Write a @file{CONTENTS} DCF file from an Rd contents db.
    ## Note that these files currently have @samp{URL:} entries which
    ## contain the package name, whereas @code{Rd_contents()} works on
    ## collections of Rd files which do not necessarily all come from
    ## the same package ...

    ## If the contents is 'empty', return immediately.  (Otherwise,
    ## e.g. URLs would not be right ...)
    if(!NROW(contents)) return()

    ## <NOTE>
    ## This has 'html' hard-wired.
    ## Note that slashes etc. should be fine for URLs.
    URLs <- paste0("../../../library/", packageName, "/html/",
                   file_path_sans_ext(contents[ , "File"]),
                   ".html")
    ## </NOTE>

    if(is.data.frame(contents))
        contents <-
            cbind(contents$Name,
                  sapply(contents$Aliases, paste, collapse = " "),
                  sapply(contents$Keywords, paste, collapse = " "),
                  contents$Title)
    else
        contents <-
            contents[, c("Name", "Aliases", "Keywords", "Title"),
                     drop = FALSE]

    cat(paste(c("Entry:", "Aliases:", "Keywords:", "Description:",
                "URL:"),
              t(cbind(contents, URLs))),
        sep = c("\n", "\n", "\n", "\n", "\n\n"),
        file = outFile)
}
}

### * .build_Rd_index

.build_Rd_index <-
function(contents, type = NULL)
{
    ## Build an Rd 'index' containing Rd "names" (see below) and titles,
    ## maybe subscripted according to the Rd type (\docType).

    keywords <- contents[ , "Keywords"]

    if(!is.null(type)) {
        idx <- contents[ , "Type"] %in% type
        ## Argh.  Ideally we only want to subscript according to
        ## \docType.  Maybe for 2.0 ...
        if(type == "data")
            idx <- idx | keywords == "datasets"
        ## (Note: we really only want the Rd objects which have
        ## 'datasets' as their *only* keyword.)
        contents <- contents[idx, , drop = FALSE]
        keywords <- keywords[idx]
    }

    ## Drop all Rd objects marked as 'internal' from the index.
    idx <- is.na(sapply(keywords, function(x) match("internal", x)))

    index <- contents[idx, c("Name", "Title"), drop = FALSE]
    if(nrow(index)) {
        ## If a \name is not a valid \alias, replace it by the first
        ## alias.
        aliases <- contents[idx, "Aliases"]
        bad <- which(!mapply("%in%", index[, 1L], aliases))
        if(any(bad)) {
            ## was [[, but that applies to lists not char vectors
            tmp <- sapply(aliases[bad], "[", 1L)
            tmp[is.na(tmp)] <- ""
            index[bad, 1L] <- tmp
        }
        ## and sort it by name
        index <- index[sort.list(index[, 1L]), ]
    }
    index
}

### * Rdindex

Rdindex <-
function(RdFiles, outFile = "", type = NULL,
         width = 0.9 * getOption("width"), indent = NULL)
{
    ## Create @file{INDEX} or @file{data/00Index} style files from Rd
    ## files.
    ##
    ## R version of defunct @code{R CMD Rdindex} (now removed).
    ##
    ## called from R CMD build

    if((length(RdFiles) == 1L) && file_test("-d", RdFiles)) {
        ## Compatibility code for the former @code{R CMD Rdindex}
        ## interface.
        docsDir <- RdFiles
        if(file_test("-d", file.path(docsDir, "man")))
            docsDir <- file.path(docsDir, "man")
        RdFiles <- list_files_with_type(docsDir, "docs")
    }

    if(outFile == "")
        outFile <- stdout()
    else if(is.character(outFile)) {
        outFile <- file(outFile, "w")
        on.exit(close(outFile))
    }
    if(!inherits(outFile, "connection"))
        stop("argument 'outFile' must be a character string or connection")

    db <- .build_Rd_db(files = RdFiles, stages="build")
    index <- .build_Rd_index(Rd_contents(db), type = type)
    writeLines(formatDL(index, width = width, indent = indent), outFile)
}

### * Rd_db

Rd_db <-
function(package, dir, lib.loc = NULL)
{
    ## Build an Rd 'data base' from an installed package or the unpacked
    ## package sources as a list containing the parsed Rd objects.

    ## <NOTE>
    ## We actually also process platform conditionals.
    ## If this was to be changed, we could also need to arrange that Rd
    ## objects in *all* platform specific subdirectories are included.
    ## </NOTE>

    ## Argument handling.
    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        dir <- find.package(package, lib.loc)
        ## Using package installed in @code{dir} ...
        docs_dir <- file.path(dir, "man")
        ## For an installed package, we might have
        ##
        ## 1) pre-2.10.0-style  man/package.Rd.gz
        ## file with suitable concatenated Rd sources,
        ##
        ## 2) help/package.rd[bx]
        ## with a DB of the parsed (and platform processed, see
        ## above) Rd objects.
        db_file <- file.path(dir, "help", package)
        if(file_test("-f", paste(db_file, "rdx", sep = "."))) {
            db <- fetchRdDB(db_file)
            pathfile <- file.path(dir, "help", "paths.rds")
            if(file.exists(pathfile)) {
                paths <- readRDS(pathfile)
                if(!is.null(first <- attr(paths, "first")))
                    paths <- substring(paths, first)
                names(db) <- paths
            }
            return(db)
        }
        db_file <- file.path(docs_dir, sprintf("%s.Rd.gz", package))
        if(file_test("-f", db_file)) {
            lines <- .read_Rd_lines_quietly(db_file)
            eof_pos <-
                grep("^\\\\eof$", lines, perl = TRUE, useBytes = TRUE)
            db <- split(lines[-eof_pos],
                        rep(seq_along(eof_pos),
                            times = diff(c(0, eof_pos)))[-eof_pos])
        } else return(structure(list(), names = character()))

        ## NB: we only get here for pre-2.10.0 installs

        ## If this was installed using a recent enough version of R CMD
        ## INSTALL, information on source file names is available, and
        ## we use it for the names of the Rd db.  Otherwise, remove the
        ## artificial names attribute.
        paths <- as.character(sapply(db, "[", 1L))
        names(db) <-
            if(length(paths)
               && all(grepl("^% --- Source file: (.+) ---$", paths)))
                sub("^% --- Source file: (.+) ---$", "\\1", paths)
            else
                NULL
        ## Determine package encoding.
        encoding <- .get_package_metadata(dir, TRUE)["Encoding"]
        if(is.na(encoding)) encoding <- "unknown"
        db <- suppressWarnings(lapply(db,
                                      prepare_Rd_from_Rd_lines,
                                      encoding = encoding,
                                      defines = .Platform$OS.type,
                                      stages = "install"))
    }
    else {
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        ## Using sources from directory @code{dir} ...
        if(!file_test("-d", dir))
            stop(gettextf("directory '%s' does not exist", dir),
                 domain = NA)
        else
            dir <- file_path_as_absolute(dir)
        built_file <- file.path(dir, "build", "partial.rdb")
        db <- .build_Rd_db(dir,
                           stages = "build",
                           built_file = built_file)
        if(length(db)) {
            first <- nchar(file.path(dir, "man", "")) + 1L
            names(db) <- substring(names(db), first)
        }
    }

    db

}

prepare_Rd_from_Rd_lines <-
function(x, ...)
{
    con <- textConnection(x, "rt")
    on.exit(close(con))
    prepare_Rd(con, ...)
}

.build_Rd_db <-
function(dir = NULL, files = NULL, encoding = "unknown", db_file = NULL,
         stages = c("build", "install"), os = .OStype(), step = 3L, built_file = NULL)
{
    if(!is.null(dir)) {
        dir <- file_path_as_absolute(dir)
        man_dir <- file.path(dir, "man")
        if(!file_test("-d", man_dir))
            return(structure(list(), names = character()))
        if(is.null(files))
            files <- list_files_with_type(man_dir, "docs", OS_subdirs=os)
        encoding <- .get_package_metadata(dir, FALSE)["Encoding"]
        if(is.na(encoding)) encoding <- "unknown"
    } else if(is.null(files))
        stop("you must specify 'dir' or 'files'")

    .fetch_Rd_object <- function(f) {
        ## This calls parse_Rd if f is a filename
        Rd <- prepare_Rd(f, encoding = encoding,
                         defines = os,
                         stages = stages, warningCalls = FALSE,
                         stage2 = step > 1L, stage3 = step > 2L)
        structure(Rd, prepared = step)
    }

    if(!is.null(db_file) && file_test("-f", db_file)) {
        ## message("updating database of parsed Rd files")
        db <- fetchRdDB(sub("\\.rdx$", "", db_file))
        db_names <- names(db) <-
            readRDS(file.path(dirname(db_file), "paths.rds"))
        ## Files in the db in need of updating:
        indf <- (files %in% db_names) & file_test("-nt", files, db_file)
        ## Also files not in the db:
        indf <- indf | !(files %in% db_names)

        ## Db elements missing from files:
        ind <- !(db_names %in% files) | (db_names %in% files[indf])
	if(any(ind))
            db <- db[!ind]
	files <- files[indf]
    } else
    	db <- list()

    # The built_file is a file of partially processed Rd objects, where build time
    # \Sexprs have been evaluated.  We'll put the object in place of its
    # filename to continue processing.

    names(files) <- files
    if(!is.null(built_file) && file_test("-f", built_file)) {
        basenames <- basename(files)
 	built <- readRDS(built_file)
 	names_built <- names(built)
 	if ("install" %in% stages) {
 	    this_os <- grepl(paste0("^", os, "/"), names_built)
 	    name_only <- basename(names_built[this_os])
 	    built[name_only] <- built[this_os]
 	    some_os <- grepl("/", names(built))
 	    built <- built[!some_os]
 	    names_built <- names(built)
 	}
 	built[!(names_built %in% basenames)] <- NULL
 	if (length(built)) {
 	    which <- match(names(built), basenames)
 	    if (all(file_test("-nt", built_file, files[which]))) {
 	    	files <- as.list(files)
	    	files[which] <- built
	    }
	}
    }

    if(length(files)) {
        ## message("building database of parsed Rd files")
        db1 <- lapply(files, .fetch_Rd_object)
        names(db1) <- names(files)
        db <- c(db, db1)
    }

    db
}

### * Rd_aliases

## Called from undoc and .check_Rd_xrefs
Rd_aliases <-
function(package, dir, lib.loc = NULL)
{
    ## Get the Rd aliases (topics) from an installed package or the
    ## unpacked package sources.

    if(!missing(package)) {
        dir <- find.package(package, lib.loc)
        rds <- file.path(dir, "Meta", "Rd.rds")
        if(file_test("-f", rds)) {
            aliases <- readRDS(rds)$Aliases
            if(length(aliases)) sort(unlist(aliases)) else character()
        } else
            character()
        ## <NOTE>
        ## Alternatively, we could get the aliases from the help index
        ## (and in fact, earlier versions of this code, then part of
        ## undoc(), did so), along the lines of
        ## <CODE>
        ##   help_index <- file.path(dir, "help", "AnIndex")
        ##   all_doc_topics <- if(!file_test("-f", help_index))
        ##       character()
        ##   else
        ##       sort(scan(file = helpIndex, what = list("", ""),
        ##                 sep = "\t", quote = "", quiet = TRUE,
        ##                 na.strings = character())[[1L]])
        ## </CODE>
        ## This gets all topics the same way as index.search() would
        ## find individual ones.
        ## </NOTE>
    }
    else {
        if(file_test("-d", file.path(dir, "man"))) {
            db <- Rd_db(dir = dir)
            aliases <- lapply(db, .Rd_get_metadata, "alias")
            if(length(aliases))
                sort(unique(unlist(aliases, use.names = FALSE)))
            else character()
        }
        else
            character()
    }
}

### .build_Rd_xref_db

.build_Rd_xref_db <-
function(package, dir, lib.loc = NULL)
{
    db <- if(!missing(package))
        Rd_db(package, lib.loc = lib.loc)
    else
        Rd_db(dir = dir)
    lapply(db, .Rd_get_xrefs)
}

### * .Rd_get_metadata

.Rd_get_metadata <-
function(x, kind)
{
    x <- x[RdTags(x) == sprintf("\\%s", kind)]
    if(!length(x))
        character()
    else
        unique(.strip_whitespace(sapply(x, as.character)))
}

### * .Rd_get_section

.Rd_get_section <-
function(x, which, predefined = TRUE)
{
    if(predefined)
        x <- x[RdTags(x) == paste0("\\", which)]
    else {
        ## User-defined sections are parsed into lists of length 2, with
        ## the elements the title and the body, respectively.
        x <- x[RdTags(x) == "\\section"]
        if(length(x)) {
            ind <- sapply(x, function(e) .Rd_get_text(e[[1L]])) == which
            x <- lapply(x[ind], `[[`, 2L)
        }
    }
    if(!length(x)) x else structure(x[[1L]], class = "Rd")
}

### * .Rd_deparse

.Rd_deparse <-
function(x, tag = TRUE)
{
    ## <NOTE>
    ## This should eventually get an option controlling whether to
    ## escape Rd special characters as needed (thus providing valid Rd)
    ## or not.
    ## It might also be useful to have an option for dropping comments.
    ## </NOTE>
    if(!tag)
        attr(x, "Rd_tag") <- "Rd"
    paste(as.character.Rd(x), collapse = "")
}

### * .Rd_drop_comments

.Rd_drop_comments <-
function(x)
    .Rd_drop_nodes_with_tags(x, "COMMENT")

### * .Rd_drop_nodes_with_tags

.Rd_drop_nodes_with_tags <-
function(x, tags)
{
    recurse <- function(e) {
        if(is.list(e))
            structure(lapply(e[is.na(match(RdTags(e), tags))], recurse),
                      Rd_tag = attr(e, "Rd_tag"))
        else
            e
    }
    recurse(x)
}

### * .Rd_get_argument_names

.Rd_get_argument_names <-
function(x)
{
    x <- .Rd_get_section(x, "arguments")
    if(!length(x)) return(character())
    txt <- .Rd_get_item_tags(x)
    txt <- unlist(strsplit(txt, ", *"))
    txt <- gsub("\\\\l?dots", "...", txt)
    txt <- gsub("\\\\_", "_", txt)
    .strip_whitespace(txt)
}

### * .Rd_get_argument_table

.Rd_get_argument_table <-
function(x)
{
    x <- .Rd_get_section(x, "arguments")
    if(!length(x)) return(matrix(character(), 0L, 2L))
    ## Extract two-arg \item tags at top level ... non-recursive.
    x <- x[RdTags(x) == "\\item"]
    if(!length(x)) return(matrix(character(), 0L, 2L))
    x <- lapply(x[sapply(x, length) == 2L], sapply, .Rd_deparse)
    matrix(unlist(x), ncol = 2L, byrow = TRUE)
}

### * .Rd_get_item_tags

.Rd_get_item_tags <-
function(x)
{
    ## Extract two-arg \item tags at top level ... non-recursive.
    x <- x[RdTags(x) == "\\item"]
    out <- lapply(x[sapply(x, length) == 2L],
                  function(e) .Rd_deparse(e[[1L]]))
    as.character(unlist(out))
}

### * .Rd_get_example_code

.Rd_get_example_code <-
function(x)
{
    x <- .Rd_get_section(x, "examples")
    if(!length(x)) return(character())

    ## Need to remove everything inside \dontrun (and drop comments),
    ## and "undefine" \dontshow and \testonly (which is achieved by
    ## changing the Rd tag to "Rd").

    ## <FIXME>
    ## Remove eventually.
    x <- .Rd_drop_comments(x)
    ## </FIXME>

    recurse <- function(e) {
        if(!is.null(tag <- attr(e, "Rd_tag"))
           && tag %in% c("\\dontshow", "\\testonly"))
            attr(e, "Rd_tag") <- "Rd"
        if(is.list(e)) {
            structure(lapply(e[is.na(match(RdTags(e), "\\dontrun"))],
                             recurse),
                      Rd_tag = attr(e, "Rd_tag"))
        }
        else e
    }

    .Rd_deparse(recurse(x), tag = FALSE)
}

### * .Rd_get_methods_description_table

.Rd_get_methods_description_table <-
function(x)
{
    y <- matrix(character(), 0L, 2L)
    x <- .Rd_get_section(x, "Methods", FALSE)
    if(!length(x)) return(y)
    x <- .Rd_get_section(x, "describe")
    if(!length(x)) return(y)
    x <- x[RdTags(x) == "\\item"]
    if(!length(x)) return(y)
    x <- lapply(x[sapply(x, length) == 2L], sapply, .Rd_deparse)
    matrix(unlist(x), ncol = 2L, byrow = TRUE)
}

### * .Rd_get_doc_type

.Rd_get_doc_type <-
function(x)
{
    c(attr(x, "meta")$docType, .Rd_get_metadata(x, "docType"), "")[1L]
}

### * .Rd_get_name

.Rd_get_name <-
function(x)
{
    x <- .Rd_get_section(x, "name")
    ## The name should really be plain text, so as.character() should be
    ## fine as well ...
    if(length(x))
        .strip_whitespace(.Rd_deparse(x, tag = FALSE))
    else
        character()
}

### * .Rd_get_title

.Rd_get_title <-
function(x)
{
    title <- .Rd_get_section(x, "title")

    result <- character()
    if(length(title)) {
        result <- .Rd_get_text(title)
        result <- result[result != ""]
    }
    paste(result, collapse=" ")
}

### * .Rd_get_text

# Return display form of text, encoded in UTF-8.  Note that
# textConnection converts to the local encoding, and we convert back,
# so unrepresentable characters will be lost

.Rd_get_text <-
function(x) {
    # Handle easy cases first
    if (is.character(x)) return(c(x))

    # We'd like to use capture.output here, but don't want to depend
    # on utils, so we duplicate some of it
    rval <- NULL
    file <- textConnection("rval", "w", local = TRUE)

    save <- options(useFancyQuotes = FALSE)
    Rdsave <- Rd2txt_options(underline_titles = FALSE)
    sink(file)
    tryCatch(Rd2txt(x, fragment=TRUE),
             finally = {sink()
                        options(save)
                        Rd2txt_options(Rdsave)
                        close(file)})

    if (is.null(rval)) rval <- character()
    else enc2utf8(rval)
}

### * .Rd_get_xrefs

.Rd_get_xrefs <-
function(x)
{
    out <- matrix(character(), nrow = 0L, ncol = 2L)
    recurse <- function(e) {
        tag <- attr(e, "Rd_tag")
        if(identical(tag, "\\link")) {
            val <- if(length(e)) { # mvbutils has empty links
                arg <- as.character(e[[1L]])
                opt <- attr(e, "Rd_option")
                c(arg, if(is.null(opt)) "" else as.character(opt))
            } else c("", "")
            out <<- rbind(out, val)
        } else if(identical(tag, "\\linkS4class")) {
            arg <- as.character(e[[1L]])
            val <- c(arg, sprintf("=%s-class", arg))
            out <<- rbind(out, val)
        }
        if(is.list(e)) lapply(e, recurse)
    }
    lapply(x, recurse)
    dimnames(out) <- list(NULL, c("Target", "Anchor"))
    out
}

### * .Rd_get_names_from_Rd_db

.Rd_get_names_from_Rd_db <-
function(db)
{
    Rd_names <- lapply(db, .Rd_get_name)
    ## If the Rd db was obtained from an installed package, we know that
    ## all Rd objects must have a \name entry---otherwise, Rd_info() and
    ## hence installing the package Rd contents db would have failed.
    ## For Rd dbs created from a package source directory, we now add
    ## the Rd file paths as the names attribute, so that we can point to
    ## the files with missing \name entries.
    idx <- as.integer(sapply(Rd_names, length)) == 0L
    if(any(idx)) {
        Rd_paths <- names(db)
        if(is.null(Rd_paths)) {
            ## This should not happen.
            ## We cannot refer to the bad Rd objects because we do not
            ## know their names, and have no idea which file they came
            ## from ...)
            stop("cannot deal with Rd objects with missing/empty names")
        }
        else {
            stop(sprintf(ngettext(sum(idx),
                                  "missing/empty \\name field in Rd file\n%s",
                                  "missing/empty \\name field in Rd files\n%s"),
                         paste(" ", Rd_paths[idx], collapse = "\n")),
                 call. = FALSE, domain = NA)
        }
    }
    unlist(Rd_names)
}

### * .Rd_format_title

.Rd_format_title <-
function(x)
{
    ## Although R-exts says about the Rd title slot that
    ## <QUOTE>
    ##   This should be capitalized, not end in a period, and not use
    ##   any markup (which would cause problems for hypertext search).
    ## </QUOTE>
    ## some Rd files have LaTeX-style markup, including
    ## * LaTeX-style single and double quotation
    ## * Medium and punctuation dashes
    ## * Escaped ampersand.
    ## Hence we try getting rid of these ...
    x <- gsub("(``|'')", "\"", x)
    x <- gsub("`", "'", x)
    x <- gsub("([[:alnum:]])--([[:alnum:]])", "\\1-\\2", x)
    x <- gsub("\\\\&", "&", x)
    x <- gsub("---", "--", x)
    ## Also remove leading and trailing whitespace.
    .strip_whitespace(x)
}


### * fetchRdDB

fetchRdDB <-
function(filebase, key = NULL)
{
    fun <- function(db) {
        vals <- db$vals
        vars <- db$vars
        datafile <- db$datafile
        compressed <- db$compressed
        envhook <- db$envhook

        fetch <- function(key)
            lazyLoadDBfetch(vals[key][[1L]], datafile, compressed, envhook)

        if(length(key)) {
            if(! key %in% vars)
                stop(gettextf("No help on %s found in RdDB %s",
                              sQuote(key), sQuote(filebase)),
                     domain = NA)
            fetch(key)
        } else {
            res <- lapply(vars, fetch)
            names(res) <- vars
            res
        }
    }
    res <- lazyLoadDBexec(filebase, fun)
    if (length(key))
        res
    else
        invisible(res)
}


### Local variables: ***
### mode: outline-minor ***
### outline-regexp: "### [*]+" ***
### End: ***

#  File src/library/tools/R/Rd2HTML.R
#
#  Copyright (C) 1995-2013 The R Core Team
#  Part of the R package, http://www.R-project.org
#
#  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 of the License, 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/

## also used by Rd2latex, but only 'topic' and 'dest'
get_link <- function(arg, tag, Rdfile) {
    ## 'topic' is the name to display, 'dest' is the topic to link to
    ## optionaly in package 'pkg'.  If 'target' is set it is the file
    ## to link to in HTML help

    ## \link[=bar]{foo} means shows foo but treat this as a link to bar.
    ## \link[pkg]{bar} means show bar and link to *file* bar in package pkg
    ## \link{pkg:bar]{foo} means show foo and link to file bar in package pkg.
    ## As from 2.10.0, look for topic 'bar' if file not found.

    if (!all(RdTags(arg) == "TEXT"))
    	stopRd(arg, Rdfile, "Bad \\link text")

    option <- attr(arg, "Rd_option")

    topic <- dest <- paste(unlist(arg), collapse = "")
    targetfile <- NULL
    pkg <- NULL
    if (!is.null(option)) {
        if (!identical(attr(option, "Rd_tag"), "TEXT"))
    	    stopRd(option, Rdfile, "Bad \\link option -- must be text")
    	if (grepl("^=", option, perl = TRUE, useBytes = TRUE))
    	    dest <- psub1("^=", "", option)
    	else if (grepl(":", option, perl = TRUE, useBytes = TRUE)) {
    	    targetfile <- psub1("^[^:]*:", "", option)
    	    pkg <- psub1(":.*", "", option)
    	} else {
            targetfile <- dest
    	    pkg <- as.character(option)
    	}
    }
    if (tag == "\\linkS4class") dest <- paste0(dest, "-class")
    list(topic = topic, dest = dest, pkg = pkg, targetfile = targetfile)
}


# translation of Utils.pm function of the same name, plus "unknown"
mime_canonical_encoding <- function(encoding)
{
    encoding[encoding %in% c("", "unknown")] <-
        utils::localeToCharset()[1L]
    encoding <- tolower(encoding)
    encoding <- sub("iso_8859-([0-9]+)", "iso-8859-\\1", encoding)
    encoding <- sub("iso8859-([0-9]+)", "iso-8859-\\1", encoding)
    encoding[encoding == "latin1"] <-  "iso-8859-1"
    encoding[encoding == "latin2"] <-  "iso-8859-2"
    encoding[encoding == "latin3"] <-  "iso-8859-3"
    encoding[encoding == "latin4"] <-  "iso-8859-4"
    encoding[encoding == "cyrillic"] <-"iso-8859-5"
    encoding[encoding == "arabic"] <-  "iso-8859-6"
    encoding[encoding == "greek"] <-   "iso-8859-7"
    encoding[encoding == "hebrew"] <-  "iso-8859-8"
    encoding[encoding == "latin5"] <-  "iso-8859-9"
    encoding[encoding == "latin6"] <-  "iso-8859-10"
    encoding[encoding == "latin8"] <-  "iso-8859-14"
    encoding[encoding == "latin-9"] <- "iso-8859-15"
    encoding[encoding == "latin10"] <- "iso-8859-16"
    encoding[encoding == "utf8"] <-    "utf-8"
    encoding[encoding == "ascii"] <-   "us-ascii" # from W3C validator
    encoding
}

htmlify <- function(x) {
    x <- fsub("&", "&amp;", x)
    x <- fsub("---", "&mdash;", x)
    x <- fsub("--", "&ndash;", x)
    x <- fsub("``", "&ldquo;", x)
    x <- fsub("''", "&rdquo;", x)
    x <- psub("`([^']+)'", "&lsquo;\\1&rsquo;", x)
    x <- fsub("`", "'", x)
    x <- fsub("<", "&lt;", x)
    x <- fsub(">", "&gt;", x)
    x <- fsub('"\\{"', '"{"', x)
    x <- fsub('"', '&quot;', x)
    x
}

vhtmlify <- function(x, inEqn = FALSE) { # code version
    x <- fsub("&", "&amp;", x)
    x <- fsub("<", "&lt;", x)
    x <- fsub(">", "&gt;", x)
    x <- fsub('"\\{"', '"{"', x)
    ## http://htmlhelp.com/reference/html40/entities/symbols.html
    if(inEqn) {
        x <- psub("\\\\(Alpha|Beta|Gamma|Delta|Epsilon|Zeta|Eta|Theta|Iota|Kappa|Lambda|Mu|Nu|Xi|Omicron|Pi|Rho|Sigma|Tau|Upsilon|Phi|Chi|Psi|Omega|alpha|beta|gamma|delta|epsilon|zeta|eta|theta|iota|kappa|lambda|mu|nu|xi|omicron|pi|rho|sigma|tau|upsilon|phi|chi|psi|omega|le|ge|sum|prod)", "&\\1;", x)
        x <- psub("\\\\(dots|ldots)", "&\\hellip;", x)
        x <- fsub("\\infty", "&infin;", x)
        x <- fsub("\\sqrt", "&radic;", x)
    }
    x
}

# URL encode anything other than alphanumeric, . and _

urlify <- function(x) { # make a string legal in a URL
    chars <- unlist(strsplit(x, ""))
    hex <- paste0("%", as.character(charToRaw(x)))
    mixed <- ifelse(grepl("[0-9a-zA-Z._]", chars), chars, hex)
    paste(mixed, collapse="")
}

# Ampersands should be escaped in proper HTML URIs

escapeAmpersand <- function(x) gsub("&", "&amp;", x, fixed=TRUE)

## This gets used two ways:

## 1) With dynamic = TRUE from tools:::httpd()
##    Here generated links are of the forms
##    ../../pkg/help/topic
##    file.html
##    ../../pkg/html/file.html
##    and links are never missing: topics are always linked as
##    ../../pkg/help/topic for the current packages, and this means
##    'search this package then all the others, and show all matches
##    if we need to go outside this packages'

## 2) With dynamic = FALSE from .convertRdfiles (with Links[2], used for
##    prebuilt HTML pages) and .Rdconv (no link lookup)
##    Here generated links are of the forms
##    file.html
##    ../../pkg/html/file.html
##    and missing links (those without an explicit package, and
##    those topics not in Links[2]) don't get linked anywhere.

## FIXME: better to use XHTML
Rd2HTML <-
    function(Rd, out = "", package = "", defines = .Platform$OS.type,
             Links = NULL, Links2 = NULL,
             stages = "render", outputEncoding = "UTF-8",
             dynamic = FALSE, no_links = FALSE, fragment=FALSE,
             stylesheet = "R.css", ...)
{
    if (missing(no_links) && is.null(Links) && !dynamic) no_links <- TRUE
    version <- ""
    if(!identical(package, "")) {
        if(length(package) > 1L) {
            version <- package[2L]
            package <- package[1L]
        } else {
            dir <- dirname(package)
            if((dir != "") &&
               file_test("-f", dfile <- file.path(package,
                                                  "DESCRIPTION"))) {
                version <- .read_description(dfile)["Version"]
                package <- basename(package)
            } else {
                ## Should we really do this?
                ## Used when Rdconv is given a package argument.
                version <- utils::packageDescription(package,
                                                     fields = "Version")
            }
        }
        if(is.na(version)) version <- ""
    }

    ## writeLines by default re-encodes strings to the local encoding.
    ## Avoid that by useBytes=TRUE
    writeLinesUTF8 <-
        if (outputEncoding == "UTF-8" ||
           (outputEncoding == "" && l10n_info()[["UTF-8"]])) {
        function(x, con, outputEncoding, ...)
            writeLines(x, con, useBytes = TRUE, ...)
    } else {
        function(x, con, outputEncoding, ...) {
            x <- iconv(x, "UTF-8", outputEncoding, sub="byte", mark=FALSE)
            writeLines(x, con, useBytes = TRUE, ...)
        }
    }

    of <- function(...)
        writeLinesUTF8(paste(...), con, outputEncoding, sep = "")
    of0 <- function(...)
        writeLinesUTF8(paste0(...), con, outputEncoding, sep = "")
    of1 <- function(text)
        writeLinesUTF8(text, con, outputEncoding, sep = "")

    pendingClose <- pendingOpen <- character()  # Used for infix methods

    inEqn <- FALSE		# Should we do edits needed in an eqn?
    sectionLevel <- 0L		# How deeply nested within section/subsection
    inPara <- FALSE		# Are we in a <P> paragraph? If NA, we're not, but we're not allowed to be


### These correspond to HTML wrappers
    HTMLTags <- c("\\bold"="B",
    	          "\\cite"="CITE",
                  "\\code"="code",
                  "\\command"="CODE",
                  "\\dfn"="DFN",
                  "\\emph"="EM",
                  "\\kbd"="KBD",
                  "\\preformatted"="PRE",
#                  "\\special"="PRE",
                  "\\strong"="STRONG",
                  "\\var"="VAR",
                  "\\verb"="PRE")
    # These have simple substitutions
    HTMLEscapes <- c("\\R"='<font face="Courier New,Courier" color="#666666"><b>R</b></font>',
    		     "\\cr"="<br>",
    		     "\\dots"="...",
    		     "\\ldots"="...")
    ## These correspond to idiosyncratic wrappers
    HTMLLeft <- c("\\acronym"='<acronym><span class="acronym">',
    		  "\\donttest"="",
    		  "\\env"='<span class="env">',
                  "\\file"='&lsquo;<span class="file">',
                  "\\option"='<span class="option">',
                  "\\pkg"='<span class="pkg">',
                  "\\samp"='<span class="samp">',
                  "\\sQuote"="&lsquo;",
                  "\\dQuote"="&ldquo;")
    HTMLRight <- c("\\acronym"='</span></acronym>',
    		   "\\donttest"="",
    		   "\\env"="</span>",
                   "\\file"='</span>&rsquo;',
                   "\\option"="</span>",
                   "\\pkg"="</span>",
                   "\\samp"="</span>",
                   "\\sQuote"="&rsquo;",
                   "\\dQuote"="&rdquo;")

    trim <- function(x) {
        x <- psub1("^\\s*", "", x)
        psub1("\\s*$", "", x)
    }

    addParaBreaks <- function(x) {
	if (isBlankLineRd(x) && isTRUE(inPara)) {
	    inPara <<- FALSE
	    return("</p>\n")
	}
        start <- attr(x, "srcref")[2L] # FIXME: what if no srcref?, start col
	if (start == 1) x <- psub("^\\s+", "", x)
	if (isTRUE(!inPara) && !all(grepl("^[[:blank:]\n]*$", x, perl = TRUE))) {
	    x <- c("<p>", x)
	    inPara <<- TRUE
	}
        x
    }

    enterPara <- function(enter = TRUE) {
	if (enter && isTRUE(!inPara)) {
            of0("<p>")
            inPara <<- TRUE
        }
    }

    leavePara <- function(newval) {
    	if (isTRUE(inPara)) of0("</p>\n")
    	inPara <<- newval
    }

    writeWrapped <- function(tag, block, doParas) {
    	if (!doParas || HTMLTags[tag] == "PRE")
            leavePara(NA)
        else
            enterPara()
        if (!isBlankRd(block)) {
    	    of0("<", HTMLTags[tag], ">")
    	    writeContent(block, tag)
    	    of0("</",  HTMLTags[tag], ">")
    	}
    }

    checkInfixMethod <- function(blocks)
    	# Is this a method which needs special formatting?
    	if ( length(blocks) == 1 && RdTags(blocks) == "TEXT" &&
    	     blocks[[1L]] %in% c("[", "[[", "$") ) {
    	    pendingOpen <<- blocks[[1L]]
    	    TRUE
    	} else FALSE

    writeLink <- function(tag, block, doParas) {
	parts <- get_link(block, tag, Rdfile)

        writeHref <- function() {
            enterPara(doParas)
            savePara <- inPara
            inPara <<- NA
            if (!no_links) of0('<a href="', htmlfile, '">')
            writeContent(block, tag)
            if (!no_links) of1('</a>')
            inPara <<- savePara
        }

    	if (is.null(parts$targetfile)) {
            ## ---------------- \link{topic} and \link[=topic]{foo}
            topic <- parts$dest
    	    if (dynamic) { # never called with package=""
                htmlfile <- paste0("../../", urlify(package), "/help/", urlify(topic))
                writeHref()
                return()
            } else {
            	htmlfile  <- NA_character_
            	if (!is.null(Links)) {
            	    tmp <- Links[topic]
            	    if (!is.na(tmp)) htmlfile <- tmp
                    else {
                        tmp <- Links2[topic]
                        if (!is.na(tmp)) htmlfile <- tmp
                    }
            	}
            }
            if (is.na(htmlfile)) {
                ## Used to use the search engine, but we no longer have one,
                ## and we don't get here for dynamic help.
                if (!no_links)
                    warnRd(block, Rdfile, "missing link ", sQuote(topic))
                writeContent(block, tag)
            } else {
                ## treat links in the same package specially -- was needed for CHM
                pkg_regexp <- paste0("^../../", urlify(package), "/html/")
                if (grepl(pkg_regexp, htmlfile)) {
                    htmlfile <- sub(pkg_regexp, "", htmlfile)
                }
                writeHref()
            }
    	} else {
            ## ----------------- \link[pkg]{file} and \link[pkg:file]{bar}
            htmlfile <- paste0(urlify(parts$targetfile), ".html")
            if (!dynamic && !no_links &&
               nzchar(pkgpath <- system.file(package = parts$pkg))) {
                ## check the link, only if the package is found
                OK <- FALSE
                if (!file.exists(file.path(pkgpath, "html", htmlfile))) {
                    ## does not exist as static HTML, so look harder
                    f <- file.path(pkgpath, "help", "paths.rds")
                    if (file.exists(f)) {
                        paths <- sub("\\.[Rr]d$", "", basename(readRDS(f)))
                        OK <- parts$targetfile %in% paths
                    }
                } else OK <- TRUE
                if (!OK) {
                    ## so how about as a topic?
                    file <- utils:::index.search(parts$targetfile, pkgpath)
                    if (!length(file)) {
                        warnRd(block, Rdfile,
                               "file link ", sQuote(parts$targetfile),
                               " in package ", sQuote(parts$pkg),
                               " does not exist and so has been treated as a topic")
                        parts$targetfile <- basename(file)
                    } else {
                        warnRd(block, Rdfile, "missing file link ",
                               sQuote(parts$targetfile))
                    }
                }
            }
            if (parts$pkg == package) {
                ## use href = "file.html"
                writeHref()
            } else {
                ## href = "../../pkg/html/file.html"
                htmlfile <- paste0("../../", urlify(parts$pkg), "/html/", htmlfile)
                writeHref()
            }
        }
    }

    writeComment <- function(txt) {
       	txt <- psub1("^%", "", txt)
       	txt <- fsub1("\n", "", txt)
       	txt <- fsub("--", "- - ", txt)
       	txt <- fsub(">", "&gt;", txt)
	of("<!-- ", txt, " -->\n")
    }

    writeLR <- function(block, tag, doParas) {
    	enterPara(doParas)
        of1(HTMLLeft[tag])
        writeContent(block, tag)
        of1(HTMLRight[tag])
    }

    writeDR <- function(block, tag) {
        if (length(block) > 1L) {
            of1('## Not run: ')
            writeContent(block, tag)
            of1('\n## End(Not run)')
        } else {
            of1('## Not run: ')
            writeContent(block, tag)
       }
    }

    writeBlock <- function(block, tag, blocktag) {
        doParas <- !(blocktag %in% c("\\command", "\\tabular"))
	switch(tag,
               UNKNOWN =,
               VERB = of1(vhtmlify(block, inEqn)),
               RCODE = of1(vhtmlify(block)),
               TEXT = of1(if(doParas) addParaBreaks(htmlify(block))else vhtmlify(block)),
               USERMACRO =,
               "\\newcommand" =,
               "\\renewcommand" =,
               COMMENT = {},
               LIST = writeContent(block, tag),
               "\\describe"=,
               "\\enumerate"=,
               "\\itemize" = {
               	   leavePara(FALSE)
                   writeContent(block, tag)
               },
               "\\bold" =,
               "\\cite" =,
               "\\code" =,
               "\\command" =,
               "\\dfn" =,
               "\\emph" =,
               "\\kbd" =,
               "\\preformatted" =,
               "\\strong" =,
               "\\var" =,
               "\\verb" = writeWrapped(tag, block, doParas),
               "\\special" = writeContent(block, tag), ## FIXME, verbatim?
               "\\linkS4class" =,
               "\\link" = writeLink(tag, block, doParas),
               ## cwhmisc has an empty \\email
               "\\email" = if (length(block)) {
                   url <- paste(as.character(block), collapse="")
                   url <- gsub("\n", "", url)
                   enterPara(doParas)
                   of0('<a href="mailto:', url, '">', htmlify(url), '</a>')},
               ## FIXME: encode, not htmlify
               ## watch out for empty URLs (TeachingDemos has one)
               "\\url" = if(length(block)) {
                   url <- paste(as.character(block), collapse="")
                   url <- gsub("\n", "", url)
                   enterPara(doParas)
                   of0('<a href="', escapeAmpersand(url), '">', htmlify(url), '</a>')
               },
               "\\href" = {
               	   if(length(block[[1L]])) {
               	   	url <- paste(as.character(block[[1L]]), collapse="")
               	   	url <- gsub("\n", "", url)
		        enterPara(doParas)
               	   	of0('<a href="', escapeAmpersand(url), '">')
               	   	closing <- "</a>"
               	   } else closing <- ""
               	   savePara <- inPara
               	   inPara <<- NA
               	   writeContent(block[[2L]], tag)
               	   of0(closing)
               	   inPara <<- savePara
               },
               "\\Sexpr"= of0(as.character.Rd(block, deparse=TRUE)),
               "\\cr" = of1(HTMLEscapes[tag]),
               "\\dots" =,
               "\\ldots" =,
               "\\R" = {
                   enterPara(doParas)
               	   of1(HTMLEscapes[tag])
               },
               "\\acronym" =,
               "\\donttest" =,
               "\\env" =,
               "\\file" =,
               "\\option" =,
               "\\pkg" =,
               "\\samp" =,
               "\\sQuote" =,
               "\\dQuote" =  writeLR(block, tag, doParas),
               "\\dontrun"= writeDR(block, tag),
               "\\enc" = writeContent(block[[1L]], tag),
               "\\eqn" = {
                   inEqn <<- TRUE
                   of1("<i>")
                   block <- block[[length(block)]];
                   ## FIXME: space stripping needed: see Special.html
                   writeContent(block, tag)
                   of1("</i>")
                   inEqn <<- FALSE
               },
               "\\deqn" = {
                   inEqn <<- TRUE
                   leavePara(TRUE)
                   of1('<p align="center"><i>')
                   block <- block[[length(block)]];
                   writeContent(block, tag)
                   of0('</i>')
                   leavePara(FALSE)
                   inEqn <<- FALSE
               },
               "\\figure" = {
                   ## This is what is needed for static html pages
                   if(dynamic) of1('<img src="figures/')
                   else of1('<img src="../help/figures/')
                   writeContent(block[[1]], tag)
                   of1('" ')
               	   if (length(block) > 1L
               	       && length(imgoptions <- .Rd_get_latex(block[[2]]))
		       && grepl("^options: ", imgoptions)) {
		       # There may be escaped percent signs within
		       imgoptions <- gsub("\\%", "%", imgoptions, fixed=TRUE)
                       of1(sub("^options: ", "", imgoptions))
	           } else {
		       of1('alt="')
		       writeContent(block[[length(block)]], tag)
		       of1('"')
		   }
                   of1(' />')
               },
               "\\dontshow" =,
               "\\testonly" = {}, # do nothing
               "\\method" =,
               "\\S3method" =,
               "\\S4method" = {
                   # Should not get here
               },
               "\\tabular" = writeTabular(block),
               "\\subsection" = writeSection(block, tag),
               "\\if" =,
               "\\ifelse" =
               	    if (testRdConditional("html", block, Rdfile))
			writeContent(block[[2L]], tag)
		    else if (tag == "\\ifelse")
		    	writeContent(block[[3L]], tag),
               "\\out" = for (i in seq_along(block))
		   of1(block[[i]]),
               stopRd(block, Rdfile, "Tag ", tag, " not recognized")
               )
    }

    writeTabular <- function(table) {
    	format <- table[[1L]]
    	content <- table[[2L]]
    	if (length(format) != 1 || RdTags(format) != "TEXT")
    	    stopRd(table, Rdfile, "\\tabular format must be simple text")
    	format <- strsplit(format[[1L]], "", fixed = TRUE)[[1L]]
    	if (!all(format %in% c("l", "c", "r")))
    	    stopRd(table, Rdfile,
                   "Unrecognized \\tabular format: ", table[[1L]][[1L]])
        format <- c(l="left", c="center", r="right")[format]

        tags <- RdTags(content)

	leavePara(FALSE)
	of1('\n<table summary="Rd table">\n')
        newrow <- TRUE
        newcol <- TRUE
        for (i in seq_along(tags)) {
            if (newrow) {
            	of1("<tr>\n ")
            	newrow <- FALSE
            	col <- 0
            }
            if (newcol) {
                col <- col + 1L
                if (col > length(format))
                    stopRd(table, Rdfile,
                           "Only ", length(format),
                           " columns allowed in this table")
            	of0('<td align="', format[col], '">')
            	newcol <- FALSE
            }
            switch(tags[i],
            "\\tab" = {
            	of1('</td>')
            	newcol <- TRUE
            },
            "\\cr" = {
            	if (!newcol) of1('</td>')
            	of1('\n</tr>\n')
            	newrow <- TRUE
            	newcol <- TRUE
            },
            writeBlock(content[[i]], tags[i], "\\tabular"))
            leavePara(FALSE)
        }
        if (!newcol) of1('</td>')
        if (!newrow) of1('\n</tr>\n')
        of1('\n</table>\n')
    }

    writeContent <- function(blocks, blocktag) {
        inlist <- FALSE
        itemskip <- FALSE

	tags <- RdTags(blocks)

	i <- 0
	while (i < length(tags)) {
	    i <- i + 1
            tag <- tags[i]
            block <- blocks[[i]]
            if (length(pendingOpen)) { # Handle $, [ or [[ methods
            	if (tag == "RCODE" && grepl("^\\(", block)) {
            	    block <- sub("^\\(", "", block)
            	    arg1 <- sub("[,)[:space:]].*", "", block)
		    block <- sub(paste0(arg1, "[[:space:]]*,[[:space:]]*"),
				 "", block)
            	    of0(arg1, pendingOpen)
            	    if (pendingOpen == "$")
            	    	pendingClose <<- ""
            	    else
            	    	pendingClose <<- chartr("[", "]", pendingOpen)
            	} else of0("`", pendingOpen, "`")
            	pendingOpen <<- character()
            }
            if (length(pendingClose) && tag == "RCODE"
                && grepl("\\)", block)) { # Finish it off...
            	of0(sub("\\).*", "", block), pendingClose)
            	block <- sub("[^)]*\\)", "", block)
            	pendingClose <<- character()
            }
            switch(tag,
            "\\method" =,
            "\\S3method" =,
            "\\S4method" = {
               	blocks <- transformMethod(i, blocks, Rdfile)
               	tags <- RdTags(blocks)
               	i <- i - 1
            },
            "\\item" = {
    	    	leavePara(FALSE)
    	    	if (!inlist) {
    	    	    switch(blocktag,
                           "\\value" =  of1('<table summary="R valueblock">\n'),
                           "\\arguments" = of1('<table summary="R argblock">\n'),
                           "\\itemize" = of1("<ul>\n"),
                           "\\enumerate" = of1("<ol>\n"),
                           "\\describe" = of1("<dl>\n"))
    	    	    inlist <- TRUE
    		} else {
    		    if (blocktag %in% c("\\itemize", "\\enumerate")) {
    		    	of1("</li>\n")
                        ## We have \item ..., so need to skip the space.
                        itemskip <- TRUE
                    }
    		}
    		switch(blocktag,
   		"\\value"=,
     		"\\arguments"={
    		    of1('<tr valign="top"><td><code>')
    		    inPara <<- NA
    		    writeContent(block[[1L]], tag)
    		    of1('</code></td>\n<td>\n')
    		    inPara <<- FALSE
    		    writeContent(block[[2L]], tag)
    		    leavePara(FALSE)
    		    of1('</td></tr>')
    		},
    		"\\describe"= {
    		    of1("<dt>")
    		    inPara <<- NA
    		    writeContent(block[[1L]], tag)
    		    of1("</dt><dd>")
    		    inPara <<- FALSE
    		    writeContent(block[[2L]], tag)
    		    leavePara(FALSE)
    		    of1("</dd>")
    		},
    		"\\enumerate" =,
    		"\\itemize"= {
    		    inPara <<- FALSE
    		    of1("<li>")
    		})
    	    },
    	    { # default
    	    	if (inlist && !(blocktag %in% c("\\itemize", "\\enumerate"))
    	    	           && !(tag == "TEXT" && isBlankRd(block))) {
    	    	    switch(blocktag,
    	    	    "\\arguments" =,
     	    	    "\\value" = of1("</table>\n"),
    	    	    "\\describe" = of1("</dl>\n"))
    		    inlist <- FALSE
    		    inPara <<- FALSE
    		}
                if (itemskip) {
                    ## The next item must be TEXT, and start with a space.
                    itemskip <- FALSE
                    if (tag == "TEXT") {
                        txt <- addParaBreaks(htmlify(block))
                        of1(txt)
                    } else writeBlock(block, tag, blocktag) # should not happen
                } else writeBlock(block, tag, blocktag)
    	    })
	}
	if (inlist) {
	    leavePara(FALSE)
	    switch(blocktag,
		"\\value"=,
		"\\arguments" = of1("</table>\n"),
		"\\itemize" = of1("</li></ul>\n"),
		"\\enumerate" = of1("</li></ol>\n"),
		# "\\value"=,
		"\\describe" = of1("</dl>\n"))
	}
    }

    writeSection <- function(section, tag) {
        if (tag %in% c("\\alias", "\\concept", "\\encoding", "\\keyword"))
            return() ## \alias only used on CHM header

        leavePara(NA)
        save <- sectionLevel
        sectionLevel <<- sectionLevel + 1L
    	of1(paste0("\n\n<h", sectionLevel+2L, ">"))

    	if (tag == "\\section" || tag == "\\subsection") {
    	    title <- section[[1L]]
    	    section <- section[[2L]]
            ## FIXME: this needs trimming of whitespace
    	    writeContent(title, tag)
    	} else
    	    of1(sectionTitles[tag])
        of1(paste0("</h", sectionLevel+2L, ">\n\n"))
        if (tag %in% c("\\examples", "\\usage")) {
            of1("<pre>")
            inPara <<- NA
            pre <- TRUE
        } else {
            inPara <<- FALSE
            pre <- FALSE
        }
    	if (length(section)) {
	    ## There may be an initial \n, so remove that
	    s1 <- section[[1L]][1L]
	    if (RdTags(section)[1] == "TEXT" && s1 == "\n") section <- section[-1L]
	    writeContent(section, tag)
	}
	leavePara(FALSE)
	if (pre) of0("</pre>\n")
    	sectionLevel <<- save
    }

    if (is.character(out)) {
        if (out == "") {
            con <- stdout()
        } else {
	    con <- file(out, "wt")
	    on.exit(close(con))
	}
    } else {
    	con <- out
    	out <- summary(con)$description
    }

    Rd <- prepare_Rd(Rd, defines = defines, stages = stages,
                     fragment = fragment, ...)
    Rdfile <- attr(Rd, "Rdfile")
    sections <- RdTags(Rd)
    if (fragment) {
    	if (sections[1L] %in% names(sectionOrder))
    	    for (i in seq_along(sections))
    	    	writeSection(Rd[[i]], sections[i])
    	else
    	    for (i in seq_along(sections))
    	    	writeBlock(Rd[[i]], sections[i], "")
    } else {
	name <- htmlify(Rd[[2L]][[1L]])

	of0('<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">\n',
	    '<html><head><title>')
	headtitle <- strwrap(.Rd_format_title(.Rd_get_title(Rd)),
	                     width=65, initial="R: ")
	if (length(headtitle) > 1) headtitle <- paste0(headtitle[1], "...")
	of1(htmlify(headtitle))
	of0('</title>\n',
	    '<meta http-equiv="Content-Type" content="text/html; charset=',
	    mime_canonical_encoding(outputEncoding),
	    '">\n')

	of0('<link rel="stylesheet" type="text/css" href="',
	    stylesheet,
	    '">\n',
	    '</head><body>\n\n',
	    '<table width="100%" summary="page for ', htmlify(name))
	if (nchar(package))
	    of0(' {', package, '}"><tr><td>',name,' {', package,'}')
	else
	    of0('"><tr><td>',name)
	of0('</td><td align="right">R Documentation</td></tr></table>\n\n')

	of1("<h2>")
	inPara <- NA
	title <- Rd[[1L]]
	writeContent(title,sections[1])
	of1("</h2>")
	inPara <- FALSE

	for (i in seq_along(sections)[-(1:2)])
	    writeSection(Rd[[i]], sections[i])

	if(version != "")
	    version <- paste0('Package <em>',package,'</em> version ',version,' ')
	of0('\n')
	if (version != "")
	    of0('<hr><div align="center">[', version,
		if (!no_links) '<a href="00Index.html">Index</a>',
		']</div>')
	of0('\n',
	    '</body></html>\n')
    }
    invisible(out)
}

findHTMLlinks <- function(pkgDir = "", lib.loc = NULL, level = 0:2)
{
    ## The priority order is
    ## This package (level 0)
    ## The standard packages (level 1)
    ## along lib.loc (level 2)

    if (is.null(lib.loc)) lib.loc <- .libPaths()

    Links <- list()
    if (2 %in% level)
        Links <- c(Links, lapply(rev(lib.loc), .find_HTML_links_in_library))
    if (1 %in% level) {
        base <- unlist(.get_standard_package_names()[c("base", "recommended")],
                       use.names = FALSE)
        Links <- c(Links,
                   lapply(file.path(.Library, base),
                          .find_HTML_links_in_package))
    }
    if (0 %in% level && nzchar(pkgDir))
        Links <- c(Links, list(.find_HTML_links_in_package(pkgDir)))
    Links <- unlist(Links)

    ## now latest names are newest, so
    Links <- rev(Links)
    Links <- Links[!duplicated(names(Links))]
    gsub("[Rr]d$", "html", Links)
}

.find_HTML_links_in_package <-
function(dir)
{
    if (file_test("-f", f <- file.path(dir, "Meta", "links.rds")))
        readRDS(f)
    else if (file_test("-f", f <- file.path(dir, "Meta", "Rd.rds")))
        .build_links_index(readRDS(f), basename(dir))
    else character()
}

.find_HTML_links_in_library <-
function(dir)
{
    if (file_test("-f", f <- file.path(dir, ".Meta", "links.rds")))
        readRDS(f)
    else
        .build_library_links_index(dir)
}

.build_library_links_index <-
function(dir)
{
    unlist(lapply(rev(dir(dir, full.names = TRUE)),
                  .find_HTML_links_in_package))
}
#  File src/library/tools/R/Rd2ex.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/

## This warns on multiple \examples sections, never fails.

Rd2ex <-
    function(Rd, out="", defines=.Platform$OS.type, stages="render",
             outputEncoding="UTF-8", commentDontrun = TRUE, ...)
{
    encode_warn <- FALSE
    WriteLines <- function(x, con, outputEncoding, ...) {
        if (outputEncoding != "UTF-8") {
            x <- iconv(x, "UTF-8", outputEncoding,  mark=FALSE)
            if (anyNA(x)) {
                x <- iconv(x, "UTF-8", outputEncoding, sub="byte", mark=FALSE)
                encode_warn <<- TRUE
            }
        }
        writeLines(x, con, useBytes = TRUE, ...)
    }

    dropNewline <- FALSE # drop next char if newline

    of0 <- function(...)
        of1(paste0(...))
    of1 <- function(text) {
        if (dropNewline && length(text)) {
            text[1L] <- psub("^\n", "", text[1L])
            dropNewline <<- FALSE
        }
        WriteLines(text, con, outputEncoding, sep = "")
    }
    wr <- function(x)
	paste0("###", strwrap(remap(x), 73L, indent=1L, exdent=3L), collapse="\n")

    remap <- function(x) {
        if(!length(x)) return(x)
        ## \link, \var are untouched in comments: e.g. is.R
        x <- psub("\\\\(link|var)\\{([^}]+)\\}", "\\2", x)
        ## not valid in perl: use lookbehind instead.
        ## x <- gsub("(^|[^\\])\\\\([%{])", "\\1\\2", x)
        x <- psub("(?<!\\\\)\\\\([%{])", "\\1", x)
        x <- psub("\\\\(l|)dots", "...", x)
        ## FIXME:  Previously said "Want to leave file bytes unchanged"
        x
    }

    render <- function(x, prefix = "")
    {
        tag <- attr(x, "Rd_tag")
        if(tag %in% c("\\dontshow", "\\testonly")) {
            of1("## Don't show: ")
            if (!grepl("^\n", x[[1L]][1L], perl = TRUE) && RdTags(x)[1L] != "COMMENT")
                writeLines("", con)
            for(i in seq_along(x)) render(x[[i]], prefix)
            last <- x[[length(x)]]
            if (!grepl("\n$", last[length(last)], perl = TRUE))
                writeLines("", con)
            of1("## End Don't show")
        } else if (tag  == "\\dontrun") {
            if (commentDontrun)
                of1("## Not run: ")
            ## Special case for one line.
            if (length(x) == 1L && commentDontrun) {
                render(x[[1L]], prefix)
            } else {
                if (!grepl("^\n", x[[1L]][1L], perl = TRUE) && RdTags(x)[1L] != "COMMENT") {
                    writeLines("", con)
                    render(x[[1L]], paste0(if (commentDontrun) "##D ", prefix))
                } else render(x[[1L]], prefix)
                for(i in 2:length(x)) render(x[[i]], paste0(if (commentDontrun) "##D ", prefix))
                last <- x[[length(x)]]
                if (!grepl("\n$", last[length(last)], perl = TRUE))
                    writeLines("", con)
                if (commentDontrun)
                of1("## End(Not run)")
            }
        } else if (tag  == "\\donttest") {
            of1("## No test: ")
            if (!grepl("^\n", x[[1L]][1L], perl = TRUE) && RdTags(x)[1L] != "COMMENT")
                writeLines("", con)
            for(i in seq_along(x)) render(x[[i]], prefix)
            last <- x[[length(x)]]
            if (!grepl("\n$", last[length(last)], perl = TRUE))
                writeLines("", con)
            of1("## End(No test)")
        } else if (tag == "COMMENT") {
            ## % can escape a whole line (e.g. beavers.Rd) or
            ## be trailing when we want a NL
            ## This is not right (leading spaces?) but it may do
            if(attr(x, "srcref")[2L] == 1L) dropNewline <<- TRUE
        } else if (tag %in% c("\\dots", "\\ldots")) {
            of1("...")
        } else if (tag == "\\if" || tag == "\\ifelse") {
            if (testRdConditional("example", x, Rdfile))
            	for(i in seq_along(x[[2L]])) render(x[[2L]][[i]], prefix)
            else if (tag == "\\ifelse")
            	for(i in seq_along(x[[3L]])) render(x[[3L]][[i]], prefix)
        } else if (tag == "\\out") {
            for (i in seq_along(x))
            	of1(x[[i]])
        } else if (tag %in% c("USERMACRO", "\\newcommand", "\\renewcommand")) {
            # do nothing
        } else {
            txt <- unlist(x)
            of0(prefix, remap(txt))
        }
    }

    Rd <- prepare_Rd(Rd, defines=defines, stages=stages, ...)
    Rdfile <- attr(Rd, "Rdfile")
    sections <- RdTags(Rd)

    ## FIXME should we skip empty \examples sections?
    where <- which(sections == "\\examples")
    if(length(where)) {
	if (is.character(out)) {
	    if(out == "") {
		con <- stdout()
	    } else {
		con <- file(out, "wt")
		on.exit(close(con))
	    }
        } else {
            con <- out
            out <- summary(con)$description
        }

        if(length(where) > 1L)
            warning("more than one \\examples section, using the first")
        ex <- Rd[[ where[1L] ]]
        exl <- unlist(ex)
        ## Do we need to output an encoding?
        if(length(exl) && any(Encoding(exl) != "unknown")) {
            if(any(f <- sections == "\\encoding")) {
                encoding <- unlist(Rd[which(f)])[1L]
                ## FIXME: which should win here?
                if(nzchar(outputEncoding))
                    encoding <- outputEncoding
                else
                    outputEncoding <- encoding
                of0("### Encoding: ", encoding, "\n\n") #
            }
        }
        nameblk <- sections == "\\name"
        if (any(nameblk)) {
            ## perl wrapped here, but it seems unnecessary
            name <- as.character(Rd[[ which.max(nameblk) ]])
            of0("### Name: ", name, "\n")
        }
        title <- .Rd_format_title(.Rd_get_title(Rd))
        if (!length(title))
            title <- "No title found"
        of0(wr(paste0("Title: ", title)), "\n")
        aliasblks <- sections == "\\alias"
        if (any(aliasblks)) {
            aliases <- unlist(Rd[aliasblks])
            sp <- grep(" ", aliases, fixed = TRUE)
            aliases[sp] <- paste0("'", aliases[sp], "'")
            of0(wr(paste0("Aliases: ", paste(aliases, collapse=" "))),
                "\n")
        }
        keyblks <- sections == "\\keyword"
        if (any(keyblks)) {
            ## some people have only empty keyword blocks.
            keys <- unlist(Rd[keyblks])
            if(length(keys)) {
                keys <- psub("^\\s+", "", keys)
                of0(wr(paste("Keywords: ",
                             paste0(keys, collapse=" "))), "\n")
            }
        }
        writeLines(c("", "### ** Examples"), con)
        for (i in seq_along(ex)) render(ex[[i]])
        of1("\n\n\n")
    }
    invisible(out)
}
#  File src/library/tools/R/Rd2latex.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/

## TODO: can we do something useful with cross-package links?


### * .Rd_get_latex

# Return latex form of text, encoded in UTF-8.  Note that
# textConnection converts to the local encoding, and we convert back,
# so unrepresentable characters will be lost

.Rd_get_latex <-
function(x) {
    # We'd like to use capture.output here, but don't want to depend
    # on utils, so we duplicate some of it
    rval <- NULL
    file <- textConnection("rval", "w", local = TRUE)

    save <- options(useFancyQuotes = FALSE)
    sink(file)
    tryCatch(Rd2latex(x, fragment=TRUE),
             finally = {sink(); options(save); close(file)})

    if (is.null(rval)) rval <- character()
    else enc2utf8(rval)
}

latex_canonical_encoding  <- function(encoding)
{
    if (encoding == "") encoding <- utils::localeToCharset()[1L]
    encoding <- tolower(encoding)
    encoding <- sub("iso_8859-([0-9]+)", "iso-8859-\\1", encoding)
    encoding <- sub("iso8859-([0-9]+)", "iso-8859-\\1", encoding)

    encoding[encoding == "iso-8859-1"] <-  "latin1"
    encoding[encoding == "iso-8859-2"] <-  "latin2"
    encoding[encoding == "iso-8859-3"] <-  "latin3"
    encoding[encoding == "iso-8859-4"] <-  "latin4"
    encoding[encoding == "iso-8859-5"] <-  "cyrillic"
    encoding[encoding == "iso-8859-6"] <-  "arabic"
    encoding[encoding == "iso-8859-7"] <-  "greek"
    encoding[encoding == "iso-8859-8"] <-  "hebrew"
    encoding[encoding == "iso-8859-9"] <-  "latin5"
    encoding[encoding == "iso-8859-10"] <-  "latin6"
    encoding[encoding == "iso-8859-14"] <-  "latin8"
    encoding[encoding %in% c("latin-9", "iso-8859-15")] <-  "latin9"
    encoding[encoding == "iso-8859-16"] <-  "latin10"
    encoding[encoding == "utf-8"] <-  "utf8"
    encoding
}

## 'encoding' is passed to parse_Rd, as the input encoding
Rd2latex <- function(Rd, out="", defines=.Platform$OS.type, stages="render",
		     outputEncoding = "ASCII", fragment = FALSE, ...,
                     writeEncoding = TRUE)
{
    encode_warn <- FALSE
    WriteLines <-
        if(outputEncoding == "UTF-8" ||
           (outputEncoding == "" && l10n_info()[["UTF-8"]])) {
            function(x, con, outputEncoding, ...)
                writeLines(x, con, useBytes = TRUE, ...)
        } else {
            function(x, con, outputEncoding, ...) {
                x <- iconv(x, "UTF-8", outputEncoding,  mark=FALSE)
                if (anyNA(x)) {
                    x <- iconv(x, "UTF-8", outputEncoding,
                               sub="byte", mark=FALSE)
                    encode_warn <<- TRUE
                }
                writeLines(x, con, useBytes = TRUE, ...)
            }
    }

    last_char <- ""
    of0 <- function(...) of1(paste0(...))
    of1 <- function(text) {
        nc <- nchar(text)
        last_char <<- substr(text, nc, nc)
        WriteLines(text, con, outputEncoding, sep = "")
    }

    trim <- function(x) {
        x <- psub1("^\\s*", "", as.character(x))
        psub1("\\s*$", "", x)
    }

    envTitles <- c("\\description"="Description", "\\usage"="Usage",
        "\\arguments"="Arguments",
        "\\format"="Format", "\\details"="Details", "\\note"="Note",
        "\\section"="", "\\author"="Author",
        "\\references"="References", "\\source"="Source",
        "\\seealso"="SeeAlso", "\\examples"="Examples",
        "\\value"="Value")

    sectionExtras <-
    c("\\usage"="verbatim",
      "\\arguments"="ldescription",
      "\\examples"="ExampleCode")

    inCodeBlock <- FALSE ## used to indicate to texify where we are
    inCode <- FALSE
    inEqn <- FALSE
    inPre <- FALSE
    sectionLevel <- 0
    hasFigures <- FALSE

    startByte <- function(x) {
    	srcref <- attr(x, "srcref")
    	if (is.null(srcref)) NA
    	else srcref[2L]
    }

    addParaBreaks <- function(x, tag) {
        start <- startByte(x)
        if (isBlankLineRd(x)) "\n"
	else if (identical(start, 1L)) psub("^\\s+", "", x)
        else x
    }

    texify <- function(x, code = inCodeBlock) {
        if(inEqn) return(x)
        if (!code) {
	    # Need to be careful to handle backslash, so do it in three steps.
	    # First, mark all the ones in the original text, but don't add
	    # any other special chars
	    x <- fsub("\\", "\\bsl", x)
	    # Second, escape other things, introducing more backslashes
	    x <- psub("([&$%_#])", "\\\\\\1", x)
	    ## pretty has braces in text.
	    x <- fsub("{", "\\{", x)
	    x <- fsub("}", "\\}", x)
	    x <- fsub("^", "\\textasciicircum{}", x)
	    x <- fsub("~", "\\textasciitilde{}", x)
	    # Third, add the terminal braces to the backslash
	    x <- fsub("\\bsl", "\\bsl{}", x)
	} else {
	    x <- psub("\\\\[l]{0,1}dots", "...", as.character(x))
	    ## unescape (should not be escaped: but see kappa.Rd)
	    x <- psub("\\\\([$^&~_#])", "\\1", x)
	    ## inCodeBlock/inPre is in alltt, where only \ { } have their usual meaning
	    if (inCodeBlock) {
		## We do want to escape { }, but unmatched braces had
		## to be escaped in earlier versions (e.g. Paren.Rd, body.tex).
		## So fix up for now
		x <- fsub1('"\\{"', '"{"', x)
	    } else if (inPre) {
		BSL = '@BSL@';
		x <- fsub("\\", BSL, x)
		x <- psub("(?<!\\\\)\\{", "\\\\{", x)
		x <- psub("(?<!\\\\)}", "\\\\}", x)
		x <- fsub(BSL, "\\bsl{}", x)
		x <- psub("\\\\\\\\var\\\\\\{([^\\\\]*)\\\\}", "\\\\var{\\1}", x)
	    } else {
		## cat(sprintf("\ntexify in: '%s'\n", x))
		BSL = '@BSL@';
		x <- fsub("\\", BSL, x)
		x <- psub("(?<!\\\\)\\{", "\\\\{", x)
		x <- psub("(?<!\\\\)}", "\\\\}", x)
		x <- psub("(?<!\\\\)([&$%_#])", "\\\\\\1", x)
		x <- fsub("^", "\\textasciicircum{}", x)
		x <- fsub("~", "\\textasciitilde{}", x)
		x <- fsub(BSL, "\\bsl{}", x)
		## avoid conversion to guillemets
		x <- fsub("<<", "<{}<", x)
		x <- fsub(">>", ">{}>", x)
		x <- fsub(",,", ",{},", x) # ,, is a ligature in the ae font.
		## cat(sprintf("\ntexify out: '%s'\n", x))
	    }
	}
        x
    }

    # The quotes were Rd.sty macros, but Latex limitations (e.g. nesting \preformatted within)
    # mean we get better results expanding them here.

    wrappers <- list("\\dQuote" =c("``", "''"),
    		     "\\sQuote" =c("`", "'"),
    		     "\\cite"   =c("\\Cite{", "}"))

    writeWrapped <- function(block, tag) {
    	wrapper <- wrappers[[tag]]
    	if (is.null(wrapper))
    	    wrapper <- c(paste0(tag, "{"), "}")
    	of1(wrapper[1L])
    	writeContent(block, tag)
    	of1(wrapper[2L])
    }

    writeURL <- function(block, tag) {
        ## really verbatim
        if (tag == "\\url")
            url <- as.character(block)
        else {
            url <- as.character(block[[1L]])
            tag <- "\\Rhref"
        }
    	of0(tag, "{",
            gsub("\n", "", paste(as.character(url), collapse="")),
            "}")
        if (tag == "\\Rhref") {
            of1("{")
            writeContent(block[[2L]], tag)
            of1("}")
        }
    }

    ## Currently ignores [option] except for [=dest] form
    ## (as documented)
    writeLink <- function(tag, block) {
        parts <- get_link(block, tag)
        of0("\\LinkA{", latex_escape_link(parts$topic), "}{",
            latex_link_trans0(parts$dest), "}")
    }

    writeComment <- function(txt) of0(txt, '\n')

    writeDR <- function(block, tag) {
        if (length(block) > 1L) {
            of1('## Not run: ')
            writeContent(block, tag)
            of1('\n## End(Not run)')
        } else {
            of1('## Not run: ')
            writeContent(block, tag)
       }
    }

    ltxstriptitle <- function(x)
    {
        x <- fsub("\\R", "\\R{}", x)
        x <- psub("(?<!\\\\)([&$%_#])", "\\\\\\1", x)
        x <- fsub("^", "\\textasciicircum{}", x)
        x <- fsub("~", "\\textasciitilde{}", x)
        x
    }

    latex_escape_name <- function(x)
    {
        x <- psub("([$#~_&])", "\\\\\\1", x) #- escape them
        x <- fsub("{", "\\textbraceleft{}", x)
        x <- fsub("}", "\\textbraceright{}", x)
        x <- fsub("^", "\\textasciicircum{}", x)
        x <- fsub("~", "\\textasciitilde{}", x)
        x <- fsub("%", "\\Rpercent{}", x)
        x <- fsub("\\\\", "\\textbackslash{}", x)
        ## avoid conversion to guillemets
        x <- fsub("<<", "<{}<", x)
        x <- fsub(">>", ">{}>", x)
        x
    }

    latex_escape_link <- function(x)
    {
        ## _ is already escaped
        x <- fsub("\\_", "_", x)
        latex_escape_name(x)
    }

    latex_link_trans0 <- function(x)
    {
        x <- fsub("\\Rdash", ".Rdash.", x)
        x <- fsub("-", ".Rdash.", x)
        x <- fsub("\\_", ".Rul.", x)
        x <- fsub("\\$", ".Rdol.", x)
        x <- fsub("\\^", ".Rcaret.", x)
        x <- fsub("^", ".Rcaret.", x)
        x <- fsub("_", ".Rul.", x)
        x <- fsub("$", ".Rdol.", x)
        x <- fsub("\\#", ".Rhash.", x) #
        x <- fsub("#", ".Rhash.", x)   #
        x <- fsub("\\&", ".Ramp.", x)
        x <- fsub("&", ".Ramp.", x)
        x <- fsub("\\~", ".Rtilde.", x)
        x <- fsub("~", ".Rtilde.", x)
        x <- fsub("\\%", ".Rpcent.", x)
        x <- fsub("%", ".Rpcent.", x)
        x <- fsub("\\\\", ".Rbl.", x)
        x <- fsub("{", ".Rlbrace.", x)
        x <- fsub("}", ".Rrbrace.", x)
        x
    }

    latex_code_trans  <- function(x)
    {
        BSL = '@BSL@';
        LATEX_SPECIAL = '$^&~_#'
        if(grepl(LATEX_SPECIAL, x)) {
            x <- fsub("\\\\", BSL, x)
            ## unescape (should not be escaped)
            x <- psub("\\\\([$^&~_#])", "\\1", x)
            x <- psub("[$^&~_#]", "\\1&", x) #- escape them
            x <- fsub("^", "\\textasciicircum{}", x) # ^ is SPECIAL
            x <- fsub("~", "\\textasciitilde{}", x)
            x <- fsub(BSL, "\\bsl{}", x)
            x <- fsub("\\", "\\bsl{}", x)
        }
        ## avoid conversion to guillemets
        x <- fsub("<<", "<{}<", x)
        x <- fsub(">>", ">{}>", x)
        x <- fsub(",,", ",{},", x) # ,, is a ligature in the ae font.
        x <- psub("\\\\bsl{}var\\\\{([^}]+)\\\\}", "\\var{\\1}", x)
        x
}

    latex_link_trans <- function(x)
    {
        x <- fsub("<-.", "<\\Rdash.", x)
        x <- psub("<-$", "<\\Rdash", x)
        x
    }

    latex_code_alias <- function(x)
    {
        x <- fsub("{", "\\{", x)
        x <- fsub("}", "\\}", x)
        x <- psub("(?<!\\\\)([&$%_#])", "\\\\\\1", x)
        x <- fsub("^", "\\textasciicircum{}", x)
        x <- fsub("~", "\\textasciitilde{}", x)
        x <- fsub("<-", "<\\Rdash", x)
        x <- psub("([!|])", '"\\1', x)
        x
    }

    latex_code_aliasAA <- function(x)
    {
        x <- latex_code_trans(x)
        x <- latex_link_trans(x)
        psub("\\\\([!|])", '"\\1', x)
    }

    currentAlias <- NA_character_

    writeAlias <- function(block, tag) {
        alias <- as.character(block)
        aa <- "\\aliasA{"
        ## some versions of hyperref (from 6.79d) have trouble indexing these
        ## |, || in base, |.bit, %||% in ggplot2 ...
        ## And texindy used by texi2dvi > 1.135 chokes on {/(
        if(grepl("[|{(]", alias)) aa <- "\\aliasB{"
        if(is.na(currentAlias)) currentAlias <<- name
        if (pmatch(paste0(currentAlias, "."), alias, 0L)) {
            aa <- "\\methaliasA{"
        } else currentAlias <<- alias
        ## 'name' is linked from the header
        if (alias == name) return()
        alias2 <- latex_link_trans0(alias)
        of0(aa, latex_code_alias(alias), "}{",
            latex_escape_name(name), "}{", alias2, "}\n")
    }

    writeBlock <- function(block, tag, blocktag) {
	switch(tag,
               UNKNOWN =,
               VERB = of1(texify(block, TRUE)),
               RCODE = of1(texify(block, TRUE)),
               TEXT = of1(addParaBreaks(texify(block), blocktag)),
               USERMACRO =,
               "\\newcommand" =,
               "\\renewcommand" =,
               COMMENT = {},
               LIST = writeContent(block, tag),
               ## Avoid Rd.sty's \describe, \Enumerate and \Itemize:
               ## They don't support verbatim arguments, which we might need.
               "\\describe"= {
                   of1("\\begin{description}\n")
                   writeContent(block, tag)
                   of1("\n\\end{description}\n")
               },
               "\\enumerate"={
                   of1("\\begin{enumerate}\n")
                   writeContent(block, tag)
                   of1("\n\\end{enumerate}\n")
               },
               "\\itemize"= {
                   of1("\\begin{itemize}\n")
                   writeContent(block, tag)
                   of1("\n\\end{itemize}\n")
               },
               ## Verbatim-like
               "\\command"=,
               "\\env" =,
               "\\kbd"=,
               "\\option" =,
               "\\samp" = writeWrapped(block, tag),
               ## really verbatim
                "\\url"=,
               "\\href"= writeURL(block, tag),
               ## R-like
               "\\code"= {
                   inCode <<- TRUE
                   writeWrapped(block, tag)
                   inCode <<- FALSE
               },
               ## simple wrappers
               "\\acronym" =,
               "\\bold"=,
               "\\dfn"=,
               "\\dQuote"=,
               "\\email"=,
               "\\emph"=,
               "\\file" =,
               "\\pkg" =,
               "\\sQuote" =,
               "\\strong"=,
               "\\var" =,
               "\\cite" =
                   if (inCodeBlock) writeContent(block, tag)
                   else writeWrapped(block, tag),
               "\\preformatted"= {
                   inPre <<- TRUE
                   of1("\\begin{alltt}")
                   writeContent(block, tag)
                   of1("\\end{alltt}\n")
                   inPre <<- FALSE
               },
               "\\Sexpr"= { of1("\\begin{verbatim}\n")  # This is only here if processing didn't get it...
	       	            of0(as.character.Rd(block, deparse=TRUE))
	       	            of1("\n\\end{verbatim}\n")
	       	          },

               "\\verb"= {
                   of0("\\AsIs{")
                   writeContent(block, tag)
                   of1("}")
               },
               "\\special"= writeContent(block, tag), ## FIXME, verbatim?
               "\\linkS4class" =,
               "\\link" = writeLink(tag, block),
               "\\cr" = of1("\\\\{}"), ## might be followed by [
               "\\dots" =,
               "\\ldots" = of1(if(inCode || inCodeBlock) "..."  else tag),
               "\\R" = of0(tag, "{}"),
               "\\donttest" = writeContent(block, tag),
               "\\dontrun"= writeDR(block, tag),
               "\\enc" = {
                   ## some people put more things in \enc than a word,
                   ## but Rd2txt does not cover that case ....
                   if (outputEncoding == "ASCII")
                       writeContent(block[[2L]], tag)
                   else
                       writeContent(block[[1L]], tag)
               } ,
               "\\eqn" =,
               "\\deqn" = {
                   of0(tag, "{")
                   inEqn <<- TRUE
                   writeContent(block[[1L]], tag)
                   inEqn <<- FALSE
                   of0('}{}')
               },
               "\\figure" = {
               	   of0('\\Figure{')
               	   writeContent(block[[1L]], tag)
               	   of0('}{')
               	   if (length(block) > 1L) {
		       includeoptions <- .Rd_get_latex(block[[2]])
		       if (length(includeoptions)
			   && grepl("^options: ", includeoptions))
			   of0(sub("^options: ", "", includeoptions))
                   }
               	   of0('}')
               	   hasFigures <<- TRUE
               },
               "\\dontshow" =,
               "\\testonly" = {}, # do nothing
               "\\method" =,
               "\\S3method" =,
               "\\S4method" = {
                   ## should not get here
               },
               "\\tabular" = writeTabular(block),
               "\\subsection" = writeSection(block, tag),
               "\\if" =,
               "\\ifelse" =
		    if (testRdConditional("latex", block, Rdfile))
               		writeContent(block[[2L]], tag)
               	    else if (tag == "\\ifelse")
               	    	writeContent(block[[3L]], tag),
               "\\out" = for (i in seq_along(block))
		   of1(block[[i]]),
               stopRd(block, Rdfile, "Tag ", tag, " not recognized")
               )
    }

    writeTabular <- function(table) {
        ## FIXME does no check of correct format
    	format <- table[[1L]]
    	content <- table[[2L]]
    	if (length(format) != 1L || RdTags(format) != "TEXT")
    	    stopRd(table, Rdfile, "\\tabular format must be simple text")
        tags <- RdTags(content)
        of0('\n\\Tabular{', format, '}{')
        for (i in seq_along(tags)) {
            switch(tags[i],
                   "\\tab" = of1("&"),
                   "\\cr" = of1("\\\\{}"),
                   writeBlock(content[[i]], tags[i], "\\tabular"))
        }
        of1('}')
    }

    writeContent <- function(blocks, blocktag) {
        inList <- FALSE
        itemskip <- FALSE

	tags <- RdTags(blocks)

	i <- 0
	while (i < length(tags)) {
	    i <- i + 1
            block <- blocks[[i]]
            tag <- attr(block, "Rd_tag")
            ## this should not be null, but it might be in a erroneous Rd file
            if(!is.null(tag))
            switch(tag,
                   "\\method" =,
                   "\\S3method" =,
                   "\\S4method" = {
                   	blocks <- transformMethod(i, blocks, Rdfile)
                   	tags <- RdTags(blocks)
                   	i <- i - 1
                   },
                   "\\item" = {
                       if (blocktag == "\\value" && !inList) {
                           of1("\\begin{ldescription}\n")
                           inList <- TRUE
                       }
                       switch(blocktag,
                              "\\describe" = {
                                  of1('\\item[')
                                  writeContent(block[[1L]], tag)
                                  of1('] ')
                                  writeContent(block[[2L]], tag)
                              },
                              "\\value"=,
                              "\\arguments"={
                                  of1('\\item[\\code{')
                                  inCode <<- TRUE
                                  writeContent(block[[1L]], tag)
                                  inCode <<- FALSE
                                  of1('}] ')
                                  writeContent(block[[2L]], tag)
                              },
                              "\\enumerate" =,
                              "\\itemize"= {
                                  of1("\\item ")
                                  itemskip <- TRUE
                              })
                       itemskip <- TRUE
                   },
                   "\\cr" = of1("\\\\{}"), ## might be followed by [
               { # default
                   if (inList && !(tag == "TEXT" && isBlankRd(block))) {
                       of1("\\end{ldescription}\n")
                       inList <- FALSE
                   }
                   if (itemskip) {
                       ## The next item must be TEXT, and start with a space.
                       itemskip <- FALSE
                       if (tag == "TEXT") {
                           txt <- psub("^ ", "", as.character(block))
                           of1(texify(txt))
                       } else writeBlock(block, tag, blocktag) # should not happen
                   } else writeBlock(block, tag, blocktag)
               })
	}
        if (inList) of1("\\end{ldescription}\n")
    }

    writeSectionInner <- function(section, tag)
    {
        if (length(section)) {
	    ## need \n unless one follows, so
	    nxt <- section[[1L]]
	    if (!attr(nxt, "Rd_tag") %in% c("TEXT", "RCODE") ||
		substr(as.character(nxt), 1L, 1L) != "\n") of1("\n")
	    writeContent(section, tag)
	    inCodeBlock <<- FALSE
	    if (last_char != "\n") of1("\n")
	}
    }

    writeSection <- function(section, tag) {
        if (tag %in% c("\\encoding", "\\concept"))
            return()
        save <- sectionLevel
        sectionLevel <<- sectionLevel + 1
        if (tag == "\\alias")
            writeAlias(section, tag)
        else if (tag == "\\keyword") {
            key <- trim(section)
            of0("\\keyword{", latex_escape_name(key), "}{", ltxname, "}\n")
        } else if (tag == "\\section" || tag == "\\subsection") {
            macro <- c("Section", "SubSection", "SubSubSection")[min(sectionLevel, 3)]
    	    of0("%\n\\begin{", macro, "}{")
            writeContent(section[[1L]], tag)
            of1("}")
    	    writeSectionInner(section[[2L]], tag)
            of0("\\end{", macro, "}\n")
    	} else {
            title <- envTitles[tag]
            of0("%\n\\begin{", title, "}")
            if(tag %in% c("\\author", "\\description", "\\details", "\\note",
                          "\\references", "\\seealso", "\\source"))
                of1("\\relax")
            extra <- sectionExtras[tag]
            if(!is.na(extra)) of0("\n\\begin{", extra, "}")
            if(tag %in% c("\\usage", "\\examples")) inCodeBlock <<- TRUE
            writeSectionInner(section, tag)
 	    inCodeBlock <<- FALSE
            if(!is.na(extra)) of0("\\end{", extra, "}\n")
            of0("\\end{", title, "}\n")
        }
        sectionLevel <<- save
    }

    Rd <- prepare_Rd(Rd, defines=defines, stages=stages, fragment=fragment, ...)
    Rdfile <- attr(Rd, "Rdfile")
    sections <- RdTags(Rd)

    enc <- which(sections == "\\encoding")

    if (is.character(out)) {
        if(out == "") {
            con <- stdout()
        } else {
	    con <- file(out, "wt")
	    on.exit(close(con))
	}
    } else {
    	con <- out
    	out <- summary(con)$description
    }

   if (outputEncoding != "ASCII") {
        latexEncoding <- latex_canonical_encoding(outputEncoding)
        if(writeEncoding) of0("\\inputencoding{", latexEncoding, "}\n")
    } else latexEncoding <- NA

    if (fragment) {
    	if (sections[1L] %in% names(sectionOrder))
    	    for (i in seq_along(sections))
    	    	writeSection(Rd[[i]], sections[i])
    	else
    	    for (i in seq_along(sections))
    	    	writeBlock(Rd[[i]], sections[i], "")
    } else {
	## we know this has been ordered by prepare2_Rd, but
	## need to sort the aliases (if any)
	nm <- character(length(Rd))
	isAlias <- sections == "\\alias"
	sortorder <- if (any(isAlias)) {
	    nm[isAlias] <- sapply(Rd[isAlias], as.character)
	    order(sectionOrder[sections], toupper(nm), nm)
	} else  order(sectionOrder[sections])
	Rd <- Rd[sortorder]
	sections <- sections[sortorder]

	title <- .Rd_get_latex(.Rd_get_section(Rd, "title"))
        ## This might have blank lines
        title <- paste(title[nzchar(title)], collapse = " ")

	name <- Rd[[2L]]

	name <- trim(as.character(Rd[[2L]][[1L]]))
	ltxname <- latex_escape_name(name)

	of0('\\HeaderA{', ltxname, '}{',
	    ltxstriptitle(title), '}{',
	    latex_link_trans0(name), '}\n')

	for (i in seq_along(sections)[-(1:2)])
	    writeSection(Rd[[i]], sections[i])
    }
    if (encode_warn)
	warnRd(Rd, Rdfile, "Some input could not be re-encoded to ",
	       outputEncoding)
    invisible(structure(out, latexEncoding = latexEncoding,
                        hasFigures = hasFigures))
}
#  File src/library/tools/R/Rd2pdf.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/

#### R based engine for  R CMD Rdconv|Rd2pdf
####

##' @param args

##' @return ...

## base packages do not have versions and this is called on
## DESCRIPTION.in
## encodings are tricky: this may be done in a foreign encoding
## (e.g., Latin-1 in UTF-8)
.DESCRIPTION_to_latex <- function(descfile, outfile, version = "Unknown")
{
    desc <- read.dcf(descfile)[1, ]
    if (is.character(outfile)) {
        out <- file(outfile, "a")
        on.exit(close(out))
    } else out <- outfile
    cat("\\begin{description}", "\\raggedright{}", sep="\n", file=out)
    fields <- names(desc)
    fields <- fields[! fields %in% c("Package", "Packaged", "Built")]
    if ("Encoding" %in% fields)
        cat("\\inputencoding{", latex_canonical_encoding(desc["Encoding"]),
            "}\n", sep = "", file = out)
    for (f in fields) {
        ## Drop 'Authors@R' for now: this is formatted badly by \AsIs,
        ## and ideally was used for auto-generating the Author and
        ## Maintainer fields anyways ...
        if(f == "Authors@R") next
        text <- desc[f]
        ## munge 'text' appropriately (\\, {, }, "...")
        ## not sure why just these: copied from Perl Rd2dvi, then added to.
        ## KH: the LaTeX special characters are
        ##   # $ % & _ ^ ~ { } \
        ## \Rd@AsIs@dospecials in Rd.sty handles the first seven, so
        ## braces and backslashes need explicit handling.
        text <- gsub('"([^"]*)"', "\\`\\`\\1''", text, useBytes = TRUE)
        text <- gsub("\\", "\\textbackslash{}", text,
                     fixed = TRUE, useBytes = TRUE)
        text <- gsub("([{}$#_])", "\\\\\\1", text, useBytes = TRUE)
        text <- gsub("@VERSION@", version, text, fixed = TRUE, useBytes = TRUE)
        ## text can have paras, and digest/DESCRIPTION does.
        ## \AsIs is per-para.
        text <- strsplit(text, "\n\n", fixed = TRUE, useBytes = TRUE)[[1L]]
        Encoding(text) <- "unknown"
        if(f %in% c("Author", "Maintainer", "Contact"))
            text <- gsub("<([^@ ]+)@([^> ]+)>",
                         "}\\\\email{\\1@\\2}\\\\AsIs{",
                         text, useBytes = TRUE)
        if(f %in% c("URL", "BugReports", "Contact"))
            text <- gsub("(http://|ftp://|https://)([^[:space:],]+)",
                         "}\\\\url{\\1\\2}\\\\AsIs{",
                         text, useBytes = TRUE)
        text <- paste0("\\AsIs{", text, "}")
        ## Not entirely safe: in theory, tags could contain \ ~ ^.
        cat("\\item[", gsub("([#$%&_{}])", "\\\\\\1", f),
            "]", paste(text, collapse = "\n\n"),  "\n", sep = "", file=out)
    }
    cat("\\end{description}\n", file = out)
}

## workhorse of .Rd2pdf
.Rdfiles2tex <-
    function(files, outfile, encoding = "unknown", outputEncoding = "UTF-8",
             append = FALSE, extraDirs = NULL, internals = FALSE,
             silent = FALSE)
{
    if (file_test("-d", files))
        .pkg2tex(files, outfile, encoding = encoding, append = append,
                 asChapter = FALSE, extraDirs = extraDirs,
                 internals = internals, silent = silent)
    else {
        files <- strsplit(files, "[[:space:]]+")[[1L]]
        latexdir <- tempfile("ltx")
        dir.create(latexdir)
        if (!silent) message("Converting Rd files to LaTeX ...")
        if (is.character(outfile)) {
            outfile <- file(outfile, if (append) "at" else "wt")
            on.exit(close(outfile))
        }
        latexEncodings <- character()
        hasFigures <- FALSE
        for(f in files) {
            if (!silent) cat("  ", basename(f), "\n", sep="")
            if (!internals) {
                lines <- readLines(f)
                if (any(grepl("\\\\keyword\\{\\s*internal\\s*\\}",
                         lines, perl = TRUE))) next
            }
            out <-  file.path(latexdir, sub("\\.[Rr]d$", ".tex", basename(f)))
            ## people have file names with quotes in them.
            res <- Rd2latex(f, out, encoding = encoding,
                            outputEncoding = outputEncoding,
                            stages = c("build", "install", "render"))
            latexEncodings <- c(latexEncodings,
                                attr(res,"latexEncoding"))
            lines <- readLines(out)
            if (attr(res, "hasFigures")) {
                graphicspath <- paste("\\graphicspath{{",
                                      normalizePath(file.path(dirname(f), "figures"), "/"),
                                      "/}}", sep="")
            	lines <- c(graphicspath, lines)
            	hasFigures <- TRUE
            }
            writeLines(lines, outfile)
        }
        list(latexEncodings = unique(latexEncodings[!is.na(latexEncodings)]),
             hasFigures = hasFigures)
    }
}

## used for the refman (from doc/manual/Makefile*)
## and for directories from .Rdfiles2tex  (with asChapter = FALSE)
.pkg2tex <-
    function(pkgdir, outfile, internals = FALSE, asChapter = TRUE,
             encoding = "unknown", outputEncoding = "UTF-8",
             extraDirs = NULL, append = FALSE, silent = FALSE)
{
    ## sort order for topics, a little tricky
    re <- function(x) x[order(toupper(x), x)]

    ## given an installed package with a latex dir or a source package
    ## with a man dir, make a single file for use in the refman.

    options(warn = 1)
    if (missing(outfile))
        outfile <- paste0(basename(pkgdir), "-pkg.tex")

    latexEncodings <- character() # Record any encodings used in the output
    hasFigures <- FALSE           # and whether graphics is used

    ## First check for a latex dir.
    ## Second guess is this is a >= 2.10.0 package with stored .rds files.
    ## If it does not exist, guess this is a source package.
    latexdir <- file.path(pkgdir, "latex")
    if (!file_test("-d", latexdir)) {
        if (file_test("-d", file.path(pkgdir, "help"))) {
            ## So convert it
            latexdir <- tempfile("ltx")
            dir.create(latexdir)
            if (!silent) message("Converting parsed Rd's to LaTeX ",
                                 appendLF = FALSE, domain = NA)
            Rd <- Rd_db(basename(pkgdir), lib.loc = dirname(pkgdir))
            if (!length(Rd)) {
                if (is.character(outfile))
                    close(file(outfile, if (append) "at" else "wt"))
                return(invisible(character()))
            }
            cnt <- 0L
            for(f in names(Rd)) {
                bf <- basename(f)
                cnt <- cnt + 1L
                if (!silent && cnt %% 10L == 0L)
                    message(".", appendLF=FALSE, domain=NA)
                out <-  sub("[Rr]d$", "tex", basename(f))
                outfilename <- file.path(latexdir, out)
                res <- Rd2latex(Rd[[f]],
				  outfilename,
				  encoding = encoding,
				  outputEncoding = outputEncoding,
				  defines = NULL,
				  writeEncoding = !asChapter)
                latexEncodings <- c(latexEncodings,
                                    attr(res, "latexEncoding"))
                if (attr(res, "hasFigures")) {
                    lines <- readLines(outfilename)
                    graphicspath <- paste("\\graphicspath{{",
                    		    normalizePath(file.path(pkgdir, "help", "figures"), "/"),
                    		    "/}}", sep="")
                    writeLines(c(graphicspath, lines), outfilename)
                    hasFigures <- TRUE
                }
            }
            if (!silent) message(domain = NA)
        } else {
            ## As from R 2.15.3, give priority to a man dir.
            mandir <- file.path(pkgdir, "man")
            if (file_test("-d", mandir)) {
                files <- c(Sys.glob(file.path(mandir, "*.Rd")),
                           Sys.glob(file.path(mandir, "*.rd")))
                if (is.null(extraDirs)) extraDirs <- .Platform$OS.type
                for(e in extraDirs)
                    files <- c(files,
                               Sys.glob(file.path(mandir, e, "*.Rd")),
                               Sys.glob(file.path(mandir, e, "*.rd")))
                if (!length(files))
                    stop("this package has a ", sQuote("man"), " directory but no .Rd files",
                         domain = NA)
           } else {
                files <- c(Sys.glob(file.path(pkgdir, "*.Rd")),
                           Sys.glob(file.path(pkgdir, "*.rd")))
                if (!length(files))
                    stop("this package does not have either a ", sQuote("latex"),
                         " or a (source) ", sQuote("man"), " directory",
                         domain = NA)
            }
            paths <- files
            ## Use a partial Rd db if there is one.
            ## In this case, files will become a list of paths or
            ## preprocessed Rd objects to be passed to Rd2latex(), and
            ## paths will contain the corresponding paths.
            built_file <- file.path(pkgdir, "build", "partial.rdb")
            if(file_test("-f", built_file)) {
                db <- readRDS(built_file)
                pos <- match(names(db), basename(paths), nomatch = 0L)
                files <- as.list(files)
                files[pos] <- db[pos > 0L]
            }
            latexdir <- tempfile("ltx")
            dir.create(latexdir)
            if (!silent) message("Converting Rd files to LaTeX ",
                                 appendLF = FALSE, domain = NA)
            cnt <- 0L
            for(i in seq_along(paths)) {
                cnt <- cnt + 1L
                if(!silent && cnt %% 10L == 0L)
                    message(".", appendLF = FALSE, domain = NA)
                out <-  sub("\\.[Rr]d$", ".tex", basename(paths[i]))
                outfilename <- file.path(latexdir, out)
                res <- Rd2latex(files[[i]], outfilename,
                                stages = c("build", "install", "render"),
                                encoding = encoding,
                                outputEncoding = outputEncoding)
                latexEncodings <-
                    c(latexEncodings, attr(res, "latexEncoding"))
                if (attr(res, "hasFigures")) {
                    lines <- readLines(outfilename)
                    graphicspath <-
                        paste("\\graphicspath{{",
                              normalizePath(file.path(dirname(paths[i]),
                                                      "figures"),
                                            "/"),
                              "/}}",
                              sep = "")
                    writeLines(c(graphicspath, lines), outfilename)
                    hasFigures <- TRUE
                }
            }
            if (!silent) message(domain = NA)
        }
    }
    ## they might be zipped up
    if (file.exists(f <- file.path(latexdir, "Rhelp.zip"))) {
        dir.create(newdir <- tempfile("latex"))
        unzip(f, exdir = newdir)
        ## res <- system(paste("unzip -q", f, "-d", newdir))
        ## if (res) stop("unzipping latex files failed")
        latexdir <- newdir
    }
    ## There are some restrictions, but the former "[[:alnum:]]+\\.tex$" was
    ## too strict.
    files <- dir(latexdir, pattern = "\\.tex$", full.names = TRUE)
    if (!length(files))
        stop("no validly-named files in the ", sQuote("latex"), " directory",
             domain = NA)

    if (is.character(outfile)) {
        outcon <- file(outfile, if (append) "at" else "wt")
        on.exit(close(outcon))
    } else outcon <- outfile

    if (asChapter)
        cat("\n\\chapter{The \\texttt{", basename(pkgdir), "} package}\n",
            sep = "", file = outcon)
    topics <- rep.int("", length(files)); names(topics) <- files
    scanForEncoding <- !length(latexEncodings)
    for (f in files) {
        lines <- readLines(f)  # This reads as "unknown", no re-encoding done
        hd <- grep("^\\\\HeaderA", lines, value = TRUE,
                   perl = TRUE, useBytes = TRUE)
        if (!length(hd)) {
            warning("file ", sQuote(f), " lacks a header: skipping",
                    domain = NA)
            next
        }
        this <- sub("\\\\HeaderA\\{\\s*([^}]*)\\}.*", "\\1", hd[1L], perl = TRUE)
        if (!internals &&
           any(grepl("\\\\keyword\\{\\s*internal\\s*\\}", lines, perl = TRUE)))
            next
        if (scanForEncoding) {
	    enc <- lines[grepl('^\\\\inputencoding', lines, perl = TRUE)]
	    latexEncodings <- c(latexEncodings,
	                        sub("^\\\\inputencoding\\{(.*)\\}", "\\1", enc))
	}
        topics[f] <- this
    }

    topics <- topics[nzchar(topics)]
    summ <- grep("-package$", topics, perl = TRUE)
    topics <- if (length(summ)) c(topics[summ], re(topics[-summ])) else re(topics)
    for (f in names(topics)) writeLines(readLines(f), outcon)

    if (asChapter)
        cat("\\clearpage\n", file = outcon)

    invisible(list(latexEncodings = latexEncodings, hasFigures = hasFigures))
}


### * .Rdconv

## replacement R code for Perl-based R CMD Rdconv

.Rdconv <- function(args = NULL)
{
    Usage <- function() {
        cat("Usage: R CMD Rdconv [options] FILE",
            "",
            "Convert R documentation in FILE to other formats such as plain text,",
            "HTML or LaTeX.",
            "",
            "Options:",
            "  -h, --help		print short help message and exit",
            "  -v, --version		print version info and exit",
            "  -t, --type=TYPE	convert to format TYPE",
            "  --encoding=enc        use 'enc' as the output encoding",
            "  --package=pkg         use 'pkg' as the package name",
            "  -o, --output=OUT	use 'OUT' as the output file",
            "      --os=NAME		assume OS 'NAME' (unix or windows)",
            "      --OS=NAME		the same as '--os'",
            "",
            "Possible format specifications are 'txt' (plain text), 'html', 'latex',",
            "and 'example' (extract R code in the examples).",
            "",
            "The default is to send output to stdout, which is also given by '-o -'.",
            "Using '-o \"\"' will choose an output filename by removing a '.Rd'",
            "extension from FILE and adding a suitable extension.",
            "",
            "Report bugs at bugs.r-project.org .", sep = "\n")
    }

    options(showErrorCalls = FALSE, warn = 1)
    files <- character(0L)
    type <- "unknown"
    enc <- ""
    pkg <- ""
    out <- NULL
    os <- ""

    if (is.null(args)) {
        args <- commandArgs(TRUE)
        ## it seems that splits on spaces, so try harder.
        args <- paste(args, collapse=" ")
        args <- strsplit(args,'nextArg', fixed = TRUE)[[1L]][-1L]
    }

    while(length(args)) {
        a <- args[1L]
        if (a %in% c("-h", "--help")) {
            Usage()
            q("no", runLast = FALSE)
        }
        else if (a %in% c("-v", "--version")) {
            cat("Rdconv: ",
                R.version[["major"]], ".",  R.version[["minor"]],
                " (r", R.version[["svn rev"]], ")\n", sep = "")
            cat("",
                "Copyright (C) 1997-2009 The R Core Team.",
                "This is free software; see the GNU General Public License version 2",
                "or later for copying conditions.  There is NO warranty.",
                sep="\n")
            q("no", runLast = FALSE)
        } else if (a == "-t") {
            if (length(args) >= 2L) {type <- args[2L]; args <- args[-1L]}
            else stop("-t option without value", call. = FALSE)
        } else if (substr(a, 1, 7) == "--type=") {
            type <- substr(a, 8, 1000)
        } else if (substr(a, 1, 10) == "--encoding=") {
            enc <- substr(a, 11, 1000)
        } else if (substr(a, 1, 10) == "--package=") {
            pkg <- substr(a, 11, 1000)
        } else if (a == "-o") {
            if (length(args) >= 2L) {out <- args[2L]; args <- args[-1L]}
            else stop("-o option without value", call. = FALSE)
        } else if (substr(a, 1, 9) == "--output=") {
            out <- substr(a, 10, 1000)
        } else if (substr(a, 1, 5) %in% c("--os=", "--OS=")) {
            os <- substr(a, 6, 1000)
        } else if (substr(a, 1, 1) == "-") {
            message("Warning: unknown option ", sQuote(a))
        } else files <- c(files, a)
        args <- args[-1L]
    }
    if (length(files) != 1L)
        stop("exactly one Rd file must be specified", call. = FALSE)
    if (is.character(out) && !nzchar(out)) {
        ## choose 'out' from filename
        bf <- sub("\\.[Rr]d$", "", file)
        exts <- c(txt=".txt", html=".html", latex=".tex", exmaple=".R")
        out <- paste0(bf,  exts[type])
    } else if (is.null(out)) out <- ""
    if (!nzchar(os)) os <- .Platform$OS.type
    switch(type,
           "txt" = {
               Rd2txt(files, out, package=pkg, defines=os,
                      outputEncoding = enc,
                      stages = c("build", "install", "render"))
           },
           "html" = {
               if (!nzchar(enc)) enc <- "UTF-8"
               Rd2HTML(files, out, package = pkg, defines = os,
                       outputEncoding = enc, no_links = TRUE,
                       stages = c("build", "install", "render"))
           },
           "latex" = {
               if (!nzchar(enc)) enc <- "UTF-8"
               Rd2latex(files, out, defines = os,
                        outputEncoding = enc,
                        stages = c("build", "install", "render"))
           },
           "example" = {
               if (!nzchar(enc)) enc <- "UTF-8"
               Rd2ex(files, out, defines = os, outputEncoding = enc,
                     stages = c("build", "install", "render"))
           },
           "unknown" = stop("no 'type' specified", call. = FALSE),
           stop("'type' must be one of 'txt', 'html', 'latex' or 'example'",
                call. = FALSE)
           )
    invisible()
}

### * .Rd2pdf

.Rd2pdf <-
function(pkgdir, outfile, title, batch = FALSE,
         description = TRUE, only_meta = FALSE,
         enc = "unknown", outputEncoding = "UTF-8", files_or_dir, OSdir,
         internals = FALSE, index = TRUE)
{
    ## Write directly to the final location.  Encodings and figures
    ## may mean we need to make edits, but for most files one pass
    ## should be enough.
    out <- file(outfile, "wt")
    if (!nzchar(enc)) enc <- "unknown"

    desc <- NULL
    if (file.exists(f <- file.path(pkgdir, "DESCRIPTION"))) {
        desc <- read.dcf(f)[1,]
        if (enc == "unknown") {
            pkg_enc <- desc["Encoding"]
            if (!is.na(pkg_enc)) {
            	enc <- pkg_enc
            	outputEncoding <- pkg_enc
            }
        }
    }

    ## Rd2.tex part 1: header
    if (batch) writeLines("\\nonstopmode{}", out)
    cat("\\documentclass[", Sys.getenv("R_PAPERSIZE"), "paper]{book}\n",
        "\\usepackage[", Sys.getenv("R_RD4PDF", "times,inconsolata,hyper"), "]{Rd}\n",
        sep = "", file = out)
    if (index) writeLines("\\usepackage{makeidx}", out)
    inputenc <- Sys.getenv("RD2PDF_INPUTENC", "inputenc")
    ## this needs to be canonical, e.g. 'utf8'
    ## trailer is for detection if we want to edit it later.
    latex_outputEncoding <- latex_canonical_encoding(outputEncoding)
    setEncoding <-
        paste("\\usepackage[",
              latex_outputEncoding, "]{",
              inputenc, "} % @SET ENCODING@", sep="")
    useGraphicx <- "% \\usepackage{graphicx} % @USE GRAPHICX@"
    writeLines(c(setEncoding,
                 if (inputenc == "inputenx" &&
                     latex_outputEncoding == "utf8") {
                     "\\IfFileExists{ix-utf8enc.dfu}{\\input{ix-utf8enc.dfu}}{}"
                 },
    		 useGraphicx,
                 if (index) "\\makeindex{}",
                 "\\begin{document}"), out)
    if (!nzchar(title)) {
        if (is.character(desc))
            title <- paste0("Package `", desc["Package"], "'")
        else if (file.exists(f <- file.path(pkgdir, "DESCRIPTION.in"))) {
            desc <- read.dcf(f)[1,]
            title <- paste0("Package `", desc["Package"], "'")
        } else {
            if (file_test("-d", pkgdir)) {
                subj <- paste0("all in \\file{", pkgdir, "}")
            } else {
                files <- strsplit(files_or_dir, "[[:space:]]+")[[1L]]
                subj1 <- if (length(files) > 1L) " etc." else ""
                subj <- paste0("\\file{", pkgdir, "}", subj1)
            }
            subj <- gsub("([_$])", "\\\\\\1", subj)
            title <- paste("\\R{} documentation}} \\par\\bigskip{{\\Large of", subj)
        }
    }
    cat("\\chapter*{}\n",
        "\\begin{center}\n",
        "{\\textbf{\\huge ", title, "}}\n",
        "\\par\\bigskip{\\large \\today}\n",
        "\\end{center}\n", sep = "", file = out)
    if(description) {
        if(file.exists(f <- file.path(pkgdir, "DESCRIPTION")))
            .DESCRIPTION_to_latex(f, out)
        else if(file.exists(f <- file.path(pkgdir, "DESCRIPTION.in"))) {
            ## running on the sources of a base package will have
            ## DESCRIPTION.in, only.
            version <- readLines(file.path(pkgdir, "../../../VERSION"))
            .DESCRIPTION_to_latex(file.path(pkgdir, "DESCRIPTION.in"),
                                  out, version)
        }
    }

    ## Rd2.tex part 2: body
    toc <- if (file_test("-d", files_or_dir)) {
        "\\Rdcontents{\\R{} topics documented:}"
    } else ""

    latexEncodings <- character()
    hasFigures <- FALSE
    ## if this looks like a package with no man pages, skip body
    if (file.exists(file.path(pkgdir, "DESCRIPTION")) &&
        !(file_test("-d", file.path(pkgdir, "man")) ||
          file_test("-d", file.path(pkgdir, "help")) ||
          file_test("-d", file.path(pkgdir, "latex")))) only_meta <- TRUE
    if (!only_meta) {
        if (nzchar(toc)) writeLines(toc, out)
        res <- .Rdfiles2tex(files_or_dir, out, encoding = enc, append = TRUE,
                         extraDirs = OSdir, internals = internals,
                         silent = batch)
        if(length(res)) {
            latexEncodings <- res$latexEncodings
            hasFigures <- res$hasFigures
        } else {
            latexEncodings <- character()
            hasFigures <- FALSE
        }
    }

    ## Rd2.tex part 3: footer
    if (index) writeLines("\\printindex{}", out)
    writeLines("\\end{document}", out)
    close(out)

    ## Fix up encodings
    ## FIXME cyrillic probably only works with times, not ae.
    latexEncodings <- unique(latexEncodings)
    latexEncodings <- latexEncodings[!is.na(latexEncodings)]
    cyrillic <- if (nzchar(Sys.getenv("_R_CYRILLIC_TEX_"))) "utf8" %in% latexEncodings else FALSE
    encs <- latexEncodings[latexEncodings != latex_outputEncoding]
    if (length(encs) || hasFigures || cyrillic) {
        lines <- readLines(outfile)
        moreUnicode <- inputenc == "inputenx" && "utf8" %in% encs
	encs <- paste(encs, latex_outputEncoding, collapse=",", sep=",")

	if (!cyrillic) {
	    setEncoding2 <-
		paste0("\\usepackage[", encs, "]{", inputenc, "}")
	} else {
	    setEncoding2 <-
		paste(
"\\usepackage[", encs, "]{", inputenc, "}
\\IfFileExists{t2aenc.def}{\\usepackage[T2A]{fontenc}}{}", sep = "")
	}
	if (moreUnicode) {
	    setEncoding2 <-
		paste0(
setEncoding2, "
\\IfFileExists{ix-utf8enc.dfu}{\\input{ix-utf8enc.dfu}}{}")
        }
        lines[lines == setEncoding] <- setEncoding2
	if (hasFigures)
	    lines[lines == useGraphicx] <- "\\usepackage{graphicx}\\setkeys{Gin}{width=0.7\\textwidth}"
	writeLines(lines, outfile)
    }

    invisible(NULL)
}

### * .Rdnewer

## replacement for tools/Rdnewer.pl,
## called from doc/manual/Makefile
.Rdnewer <- function(dir, file)
    q("no", status = ..Rdnewer(dir, file), runLast = FALSE)

..Rdnewer <- function(dir, file, OS = .Platform$OS.type)
{
    ## Test whether any Rd file in the 'man' and 'man/$OS'
    ## subdirectories of directory DIR is newer than a given FILE.
    ## Return 0 if such a file is found (i.e., in the case of
    ## 'success'), and 1 otherwise, so that the return value can be used
    ## for shell 'if' tests.

    ## <NOTE>
    ## For now only used for the R sources (/doc/manual/Makefile.in)
    ## hence no need to also look for Rd files with '.rd' extension.
    ## </NOTE>

    if (!file.exists(file)) return(0L)
    age <- file.info(file)$mtime

    if (any(file.info(c(Sys.glob(file.path(dir, "man", "*.Rd")),
                        Sys.glob(file.path(dir, "man", "*.rd")))
                      )$mtime > age))
        return(0L)

    if (isTRUE(file.info(file.path(dir, OS))$isdir)) {
        if (any(file.info(c(Sys.glob(file.path(dir, "man", OS, "*.Rd")),
                            Sys.glob(file.path(dir, "man", OS, "*.rd")))
                          )$mtime > age))
            return(0L)
    }

    1L
}

### * ..Rd2pdf

## Driver called from R CMD Rd2pdf
## See the comments in install.R as to how this can be called directly.

..Rd2pdf <- function(args = NULL, quit = TRUE)
{
    dir.exists <- function(x) !is.na(isdir <- file.info(x)$isdir) & isdir

    do_cleanup <- function() {
        if(clean) {
            setwd(startdir)
            unlink(build_dir, recursive = TRUE)
        } else {
            cat("You may want to clean up by 'rm -rf ", build_dir, "'\n", sep="")
        }
    }

    Usage <- function() {
        cat("Usage: R CMD Rd2pdf [options] files",
            "",
            "Generate PDF output from the Rd sources specified by files, by",
            "either giving the paths to the files, or the path to a directory with",
            "the sources of a package, or an installed package.",
            "",
            "Unless specified via option '--output', the basename of the output file",
            "equals the basename of argument 'files' if this specifies a package",
            "or a single file, and 'Rd2' otherwise.",
            "",
            "The Rd sources are assumed to be ASCII unless they contain \\encoding",
            "declarations (which take priority) or --encoding is supplied or if using",
            "package sources, if the package DESCRIPTION file has an Encoding field.",
            "The output encoding defaults to the package encoding then to 'UTF-8'.",
            "",
            "Files are listed in the order given: for a package they are in alphabetic",
            "order of the \\name sections.",
            "",
            "Options:",
            "  -h, --help		print short help message and exit",
            "  -v, --version		print version info and exit",
            "      --batch		no interaction",
            "      --no-clean	do not remove created temporary files",
            "      --no-preview	do not preview generated PDF file",
            "      --encoding=enc    use 'enc' as the default input encoding",
            "      --outputEncoding=outenc",
            "                        use 'outenc' as the default output encoding",
            "      --os=NAME		use OS subdir 'NAME' (unix or windows)",
            "      --OS=NAME		the same as '--os'",
            "  -o, --output=FILE	write output to FILE",
            "      --force		overwrite output file if it exists",
            "      --title=NAME	use NAME as the title of the document",
            "      --no-index	don't index output",
            "      --no-description	don't typeset the description of a package",
            "      --internals	typeset 'internal' documentation (usually skipped)",
            "",
            "The output papersize is set by the environment variable R_PAPERSIZE.",
            "The PDF previewer is set by the environment variable R_PDFVIEWER.",
            "",
            "Report bugs at bugs.r-project.org .",
            sep = "\n")
    }

    options(showErrorCalls = FALSE, warn = 1)

    if (is.null(args)) {
        args <- commandArgs(TRUE)
        args <- paste(args, collapse=" ")
        args <- strsplit(args,'nextArg', fixed = TRUE)[[1L]][-1L]
    }

    startdir <- getwd()
    if (is.null(startdir))
        stop("current working directory cannot be ascertained")
    build_dir <- paste0(".Rd2pdf", Sys.getpid())
    title <- ""
    batch <- FALSE
    clean <- TRUE
    only_meta <- FALSE
    out_ext <- "pdf"
    output <- ""
    enc <- "unknown"
    outenc <- "latin1"
    index <- TRUE
    description <- TRUE
    internals <- FALSE
    files <- character()
    dir <- ""
    force <- FALSE

    WINDOWS <- .Platform$OS.type == "windows"

    preview <- Sys.getenv("R_PDFVIEWER", if(WINDOWS) "open" else "false")
    OSdir <- if (WINDOWS) "windows" else "unix"

    while(length(args)) {
        a <- args[1L]
        if (a %in% c("-h", "--help")) {
            Usage()
            q("no", runLast = FALSE)
        } else if (a %in% c("-v", "--version")) {
            cat("Rd2pdf: ",
                R.version[["major"]], ".",  R.version[["minor"]],
                " (r", R.version[["svn rev"]], ")\n", sep = "")
            cat("",
                "Copyright (C) 2000-2011 The R Core Team.",
                "This is free software; see the GNU General Public License version 2",
                "or later for copying conditions.  There is NO warranty.",
                sep="\n")
            q("no", runLast = FALSE)
        } else if (a == "--batch") {
            batch <- TRUE
        } else if (a == "--no-clean") {
            clean <- FALSE
        } else if (a == "--no-preview") {
            preview <- "false"
        } else if (a == "--pdf") {
            # ignore for back-compatibility
        } else if (substr(a, 1, 8) == "--title=") {
            title <- substr(a, 9, 1000)
        } else if (a == "-o") {
            if (length(args) >= 2L) {output <- args[2L]; args <- args[-1L]}
            else stop("-o option without value", call. = FALSE)
        } else if (substr(a, 1, 9) == "--output=") {
            output <- substr(a, 10, 1000)
        } else if (a == "--force") {
            force <- TRUE
        } else if (a == "--only-meta") {
            only_meta <- TRUE
        } else if (substr(a, 1, 5) == "--OS=" || substr(a, 1, 5) == "--OS=") {
            OS_type <- substr(a, 6, 1000)
        } else if (substr(a, 1, 11) == "--encoding=") {
            enc <- substr(a, 12, 1000)
        } else if (substr(a, 1, 17) == "--outputEncoding=") {
            outenc <- substr(a, 18, 1000)
        } else if (substr(a, 1, 12) == "--build-dir=") {
            build_dir <- substr(a, 13, 1000)
        } else if (a == "--no-index") {
            index <- FALSE
        } else if (a == "--no-description") {
            description <- FALSE
        } else if (a == "--internals") {
            internals <- TRUE
        } else if (substr(a, 1, 1) == "-") {
            message("Warning: unknown option ", sQuote(a))
        } else files <- c(files, a)
        args <- args[-1L]
    }

    if(!length(files)) {
        message("no inputs")
        q("no", status = 1L, runLast = FALSE)
    }

    ## Windows does not allow .../man/, say, for a directory
    if(WINDOWS) files[1L] <- sub("[\\/]$", "", files[1L])
    if(dir.exists(files[1L])) {
        if(file.exists(file.path(files[1L], "DESCRIPTION"))) {
            cat("Hmm ... looks like a package\n")
            dir <- files[1L]
            if(!nzchar(output)) output <- paste(basename(dir), out_ext, sep = ".")
        } else if (file.exists(f <- file.path(files[1L], "DESCRIPTION.in"))
                   && any(grepl("^Priority: *base", readLines(f)))) {
            cat("Hmm ... looks like a package from the R distribution\n")
            dir <- files[1L]
            if(!nzchar(output)) output <- paste(basename(dir), out_ext, sep = ".")
            if(index && basename(dir) == "base") {
                index <- FALSE
                cat("_not_ indexing 'base' package\n")
            }
        } else {
            dir <- if(dir.exists(d <- file.path(files[1L], "man"))) d else files[1L]
        }
    } else {
        if(length(files) == 1L && !nzchar(output))
            output <- paste(sub("[.][Rr]d$", "", basename(files)), out_ext, sep = ".")
    }

    if(!nzchar(dir)) dir <- paste(files, collapse = " ")

    ## Prepare for building the documentation.
    if(dir.exists(build_dir) && unlink(build_dir, recursive = TRUE)) {
        cat("cannot write to build dir\n")
        q("no", status = 2L, runLast = FALSE)
    }
    dir.create(build_dir, FALSE)
    if(!nzchar(output)) output <- paste("Rd2", out_ext, sep = ".")
    if(file.exists(output) && !force) {
        cat("file", sQuote(output), "exists; please remove it first\n")
        q("no", status = 1L, runLast = FALSE)
    }

    res <-
        try(.Rd2pdf(files[1L], file.path(build_dir, "Rd2.tex"),
                    title, batch, description, only_meta,
                    enc, outenc, dir, OSdir, internals, index))
    if (inherits(res, "try-error"))
        q("no", status = 11L, runLast = FALSE)

    if (!batch)  cat("Creating", out_ext, "output from LaTeX ...\n")
    setwd(build_dir)

    res <- try(texi2pdf('Rd2.tex', quiet = FALSE, index = index))
    if (inherits(res, "try-error")) {
        message("Error in running tools::texi2pdf()")
        do_cleanup()
        q("no", status = 1L, runLast = FALSE)
    }

    setwd(startdir)
    cat("Saving output to", sQuote(output), "...\n")
    file.copy(file.path(build_dir, paste("Rd2", out_ext, sep = ".")), output,
              overwrite = force)
    cat("Done\n")

    do_cleanup()
    if(preview != "false") system(paste(preview, output))
    if (quit)
    	q("no", runLast = FALSE)
}


### Local variables: ***
### mode: outline-minor ***
### outline-regexp: "### [*]+" ***
### End: ***
#  File src/library/tools/R/Rd2txt.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/

## This stops on
##  unrecognized tag
##  \\tabular format must be simple text
##  too many columns for format
##  invalid markup in \[S3]method
##  "Tag ", tag, " not expected in code block"

tabExpand <- function(x) {
    srcref <- attr(x, "srcref")
    if (is.null(srcref)) start <- 0L
    else start <- srcref[5L] - 1L
    .Call(doTabExpand, x, start)
}

Rd2txt_options <- local({
    opts <- list(width = 80L,
                 minIndent = 10L,
    	         extraIndent = 4L,
    	         sectionIndent = 5L,
    	         sectionExtra = 2L,
    	         itemBullet = "* ",
    	         enumFormat = function(n) sprintf("%d. ", n),
    	         showURLs = FALSE,
                 code_quote = TRUE,
                 underline_titles = TRUE)
    function(...) {
        args <- list(...)
        if (!length(args))
            return(opts)
        else {
            if (is.list(args[[1L]])) args <- args[[1L]]
            result <- opts[names(args)]
            opts[names(args)] <<- args
            invisible(result)
        }
    }
})

transformMethod <- function(i, blocks, Rdfile) {
    editblock <- function(block, newtext)
    	list(structure(newtext, Rd_tag = attr(block, "Rd_tag"),
    	                   srcref = attr(block, "srcref")))

    # Most of the internal functions below are more like macros
    # than functions; they mess around with these variables:

    chars <- NULL
    char <- NULL
    j <- NULL

    findOpen <- function(i) {
    	j <- i
    	char <- NULL
    	while (j < length(blocks)) {
    	    j <- j + 1L
    	    tag <- attr(blocks[[j]], "Rd_tag")
    	    if (tag == "RCODE") {

    	        # FIXME:  This search and the ones below will be fooled
    	        # by "#" comments

    	    	chars <- strsplit(blocks[[j]], "")[[1]]
    		parens <- cumsum( (chars == "(") - (chars == ")") )
    		if (any(parens > 0)) {
		    char <- which.max(parens > 0)
    	   	    break
    	   	}
    	    }
    	}
    	if (is.null(char))
    	    stopRd(block, Rdfile, sprintf("no parenthesis following %s", blocktag))
    	chars <<- chars
    	char <<- char
    	j <<- j
    }

    findComma <- function(i) {
	j <- i
	level <- 1L
	char <- NULL
	while (j < length(blocks)) {
	    j <- j + 1L
	    tag <- attr(blocks[[j]], "Rd_tag")
	    if (tag == "RCODE") {
		chars <- strsplit(blocks[[j]], "")[[1]]
		parens <- level + cumsum( (chars == "(") - (chars == ")") )
		if (any(parens == 1 & chars == ",")) {
		    char <- which.max(parens == 1 & chars == ",")
		    break
		}
		if (any(parens == 0))
		    break
		level <- parens[length(parens)]
	    }
	}
	if (is.null(char))
	    stopRd(block, Rdfile, sprintf("no comma in argument list following %s", blocktag))
        chars <<- chars
        char <<- char
        j <<- j
    }


    findClose <- function(i) {
        j <- i
    	level <- 1L
    	char <- NULL
    	while (j < length(blocks)) {
    	    j <- j + 1L
    	    tag <- attr(blocks[[j]], "Rd_tag")
    	    if (tag == "RCODE") {
    	    	chars <- strsplit(blocks[[j]], "")[[1]]
    	    	parens <- level + cumsum( (chars == "(") - (chars == ")") )
    	    	if (any(parens == 0)) {
    	    	    char <- which(parens == 0)[1]
    	    	    break
    	    	}
    	    	level <- parens[length(parens)]
    	    }
    	}
    	if (is.null(char))
    	    stopRd(block, Rdfile, sprintf("no closing parenthesis following %s", blocktag))
	chars <<- chars
        char <<- char
        j <<- j
    }

    rewriteBlocks <- function()
    	c(blocks[seq_len(j-1L)],
    	            editblock(blocks[[j]],
    	                      paste(chars[seq_len(char)], collapse="")),
    	            if (char < length(chars))
    	                editblock(blocks[[j]],
    	                          paste(chars[-seq_len(char)], collapse="")),
	            if (j < length(blocks)) blocks[-seq_len(j)])

    deleteBlanks <- function() {
	while (char < length(chars)) {
	    if (chars[char + 1] == " ") {
	    	char <- char + 1
	    	chars[char] <- ""
	    } else
	    	break
	}
	char <<- char
	chars <<- chars
    }

    block <- blocks[[i]]
    blocktag <- attr(block, "Rd_tag")
    srcref <- attr(block, "srcref")
    class <- block[[2L]] # or signature
    generic <- as.character(block[[1L]])
    default <- as.character(class) == "default"

    if(generic %in% c("[", "[[", "$")) {
	## need to assemble the call by matching parens in RCODE
	findOpen(i) # Sets chars, char and j
	chars[char] <- ""
	blocks <- c(blocks[seq_len(j-1L)],
	            editblock(blocks[[j]],
	                      paste(chars[seq_len(char)], collapse="")),
	            if (char < length(chars))
	                editblock(blocks[[j]],
	                          paste(chars[-seq_len(char)], collapse="")),
	            if (j < length(blocks)) blocks[-seq_len(j)])

	findComma(j) # Sets chars, char and j
	chars[char] <- generic
	# Delete blanks after the comma
	deleteBlanks()
	blocks <- rewriteBlocks()

	findClose(j)
	# Edit the closing paren
	chars[char] <- switch(generic,
		"[" = "]",
		"[[" = "]]",
		"$" = "")
	blocks[j] <- editblock(blocks[[j]],
	                         paste(chars, collapse=""))

	methodtype <- if (grepl("<-", blocks[[j]])) "replacement " else ""
    } else if(grepl(sprintf("^%s$",
			   paste(c("\\+", "\\-", "\\*",
				   "\\/", "\\^", "<=?",
				   ">=?", "!=?", "==",
				   "\\&", "\\|", "!",
				   "\\%[[:alnum:][:punct:]]*\\%"),
				 collapse = "|")),
		   generic)) {
        ## Binary operators and unary '!'.
	findOpen(i)
	chars[char] <- ""
	blocks <- rewriteBlocks()

	if (generic != "!") {
	    findComma(j)
	    chars[char] <- paste0(" ", generic, " ")
	    # Delete blanks after the comma
	    deleteBlanks()
	    blocks <- rewriteBlocks()
	}
	findClose(j)
	chars[char] <- ""
	blocks[j] <- editblock(blocks[[j]],
	                         paste(chars, collapse=""))

	methodtype <- ""
    } else {
        findOpen(i)
	chars[char] <- paste0(generic, "(")
	blocks <- rewriteBlocks()
	findClose(j)
	methodtype <- if (grepl("<-", blocks[[j]])) "replacement " else ""
    }

    if (blocktag == "\\S4method") {
        ## some signatures are very long.
        blocks <- if(nchar(class) > 50L) {
            cl <- paste0("'", as.character(class), "'")
            if(nchar(cl) > 70L) {
                cl <- strsplit(cl, ",")[[1L]]
                ncl <- length(cl)
                cl[-ncl] <- paste0(cl[-ncl], ",")
                cl[-1L] <- paste0("  ", cl[-1L])
            }
            cl <- paste("##", cl, collapse="\n")
            c( blocks[seq_len(i-1L)],
              list(structure(paste0("## S4 ", methodtype, "method for signature \n"),
                             Rd_tag="RCODE", srcref=srcref)),
              list(structure(cl, Rd_tag="TEXT", srcref=srcref)),
              list(structure("\n", Rd_tag="RCODE", srcref=srcref)),
              blocks[-seq_len(i)] )
        } else
            c( blocks[seq_len(i-1L)],
              list(structure(paste0("## S4 ", methodtype, "method for signature '"),
                             Rd_tag="RCODE", srcref=srcref)),
              class,
              list(structure("'\n", Rd_tag="RCODE", srcref=srcref)),
              blocks[-seq_len(i)] )
    } else if (default)
    	blocks <- c( blocks[seq_len(i-1)],
    		     list(structure(paste0("## Default S3 ", methodtype, "method:\n"),
    		     	       Rd_tag="RCODE", srcref=srcref)),
    		     blocks[-seq_len(i)] )
    else
    	blocks <- c( blocks[seq_len(i-1)],
		     list(structure(paste0("## S3 ", methodtype, "method for class '"),
			   Rd_tag="RCODE", srcref=srcref)),
		     class,
		     list(structure("'\n", Rd_tag="RCODE", srcref=srcref)),
		     blocks[-seq_len(i)] )
    blocks
}

Rd2txt <-
    function(Rd, out="", package = "", defines=.Platform$OS.type,
             stages = "render", outputEncoding = "",
             fragment = FALSE, options, ...)
{

    ## we need to keep track of where we are.
    buffer <- character()	# Buffer not yet written to con
    				# Newlines have been processed, each line in buffer is
    				# treated as a separate input line (but may be wrapped before output)
    linestart <- TRUE		# At start of line?
    indent <- 0L		# Default indent
    wrapping <- TRUE		# Do word wrap?
    keepFirstIndent <- FALSE	# Keep first line indent?
    dropBlank <- FALSE		# Drop initial blank lines?
    haveBlanks <- 0L		# How many blank lines have just been written?
    enumItem <- 0L		# Last enumeration item number
    inEqn <- FALSE		# Should we do edits needed in an eqn?
    sectionLevel <- 0		# How deeply nested within sections/subsections

    saveOpts <- Rd2txt_options()
    on.exit(Rd2txt_options(saveOpts))# Rd files may change these, so restore them
    				     # whether or not the caller set them.
    if (!missing(options)) Rd2txt_options(options)

## these attempt to mimic pre-2.10.0 layout
    WIDTH <- 0.9 * Rd2txt_options()$width
    HDR_WIDTH <- WIDTH - 2L

    startCapture <- function() {
    	save <- list(buffer=buffer, linestart=linestart, indent=indent,
                     wrapping=wrapping, keepFirstIndent=keepFirstIndent,
                     dropBlank=dropBlank, haveBlanks=haveBlanks,
                     enumItem=enumItem, inEqn=inEqn)
    	buffer <<- character()
    	linestart <<- TRUE
    	indent <<- 0L
    	wrapping <<- TRUE
    	keepFirstIndent <<- FALSE
    	dropBlank <<- FALSE
    	haveBlanks <<- 0L
    	enumItem <<- 0L
    	inEqn <<- FALSE
    	save
    }

    endCapture <- function(saved) {
    	result <- buffer
    	buffer <<- saved$buffer
    	linestart <<- saved$linestart
    	indent <<- saved$indent
    	wrapping <<- saved$wrapping
    	keepFirstIndent <<- saved$keepFirstIndent
    	dropBlank <<- saved$dropBlank
    	haveBlanks <<- saved$haveBlanks
    	enumItem <<- saved$enumItem
    	inEqn <<- saved$inEqn
    	result
    }

    ## for efficiency
    WriteLines <-
        if(outputEncoding == "UTF-8" ||
           (outputEncoding == "" && l10n_info()[["UTF-8"]])) {
        function(x, con, outputEncoding, ...)
            writeLines(x, con, useBytes = TRUE, ...)
    } else {
        function(x, con, outputEncoding, ...) {
            x <- iconv(x, "UTF-8", outputEncoding, sub="byte", mark=FALSE)
            writeLines(x, con, useBytes = TRUE, ...)
        }
    }

    ## Use display widths as used by cat not print.
    frmt <- function(x, justify="left", width = 0L) {
        justify <- match.arg(justify, c("left", "right", "centre", "none"))
        w <- sum(nchar(x, "width")) # copes with 0-length x
        if(w < width && justify != "none") {
            excess <- width - w
            left <- right <- 0L
            if(justify == "left") right <- excess
            else if(justify == "right")  left <- excess
            else if(justify == "centre") {
                left <- excess %/% 2
                right <- excess-left
            }
            paste(c(rep_len(" ", left), x, rep_len(" ", right)), collapse = "")
        } else x
    }

    wrap <- function(doWrap = TRUE)
	if (doWrap != wrapping) { flushBuffer(); wrapping <<- doWrap }

    putw <- function(...)  { wrap(TRUE); put(...) }

    putf <- function(...)  { wrap(FALSE); put(...) }

    put <- function(...) {
        txt <- paste0(..., collapse="")
        trail <- grepl("\n$", txt)
        # Convert newlines
        txt <- strsplit(txt, "\n", fixed = TRUE)[[1L]]
        if (dropBlank) {
            while(length(txt) && grepl("^[[:space:]]*$", txt[1L]))
            	txt <- txt[-1L]
            if (length(txt)) dropBlank <<- FALSE
        }
        if(!length(txt)) return()
        haveBlanks <<- 0

        if (linestart) buffer <<- c(buffer, txt)
        else if (length(buffer)) {
            buffer[length(buffer)] <<-
                paste0(buffer[length(buffer)], txt[1L])
            buffer <<- c(buffer, txt[-1L])
        }
        else buffer <<- txt
        linestart <<- trail
    }

    blanks <- function(n)
	if (n) paste(rep_len(" ", n), collapse="") else ""

    flushBuffer <- function() {
    	if (!length(buffer)) return()

    	if (wrapping) {
	    if (keepFirstIndent) {
		first <- nchar(psub1("[^ ].*", "", buffer[1L]))
		keepFirstIndent <<- FALSE
	    } else
		first <- indent

	    buffer <<- c(buffer, "")  # Add an extra blank sentinel
	    blankLines <- grep("^[[:space:]]*$", buffer)
	    result <- character()
	    start <- 1L
	    for (i in seq_along(blankLines)) {
		if (blankLines[i] > start) {
		    result <- c(result,
                                strwrap(paste(buffer[start:(blankLines[i]-1L)],
                                              collapse = " "),
                                        WIDTH, indent = first, exdent = indent))
		    first <- indent
                }
                result <- c(result, "")
		start <- blankLines[i]+1L
	    }
            ## we want to collapse multiple blank lines when wrapping
            ## and to remove the sentinel (which we need to do first or
            ## we will drop a single blank line)
            buffer <<- result[-length(result)]
            empty <- !nzchar(buffer)
            drop <- empty & c(FALSE, empty[-length(empty)])
            buffer <<- buffer[!drop]
	} else {  # Not wrapping
	    if (keepFirstIndent) {
		if (length(buffer) > 1L)
		    buffer[-1L] <<- paste0(blanks(indent), buffer[-1L])
		keepFirstIndent <- FALSE
	    } else
		buffer <<- paste0(blanks(indent), buffer)
	}

    	if (length(buffer)) WriteLines(buffer, con, outputEncoding)
    	buffer <<- character()
    	linestart <<- TRUE
    }

    encoding <- "unknown"

    li <- l10n_info()
    ## See the comment in ?Rd2txt as to why we do not attempt fancy quotes
    ## in Windows CJK locales -- and in any case they would need more work
    ## This covers the common single-byte locales and Thai (874)
    use_fancy_quotes <-
        (.Platform$OS.type == "windows" &&
         ((li$codepage >= 1250 && li$codepage <= 1258) || li$codepage == 874)) ||
        li[["UTF-8"]]

    if(!identical(getOption("useFancyQuotes"), FALSE) &&
       use_fancy_quotes) {
        ## On Windows, Unicode literals are translated to local code page
    	LSQM <- intToUtf8("0x2018") # Left single quote
    	RSQM <- intToUtf8("0x2019") # Right single quote
    	LDQM <- intToUtf8("0x201c") # Left double quote
    	RDQM <- intToUtf8("0x201d") # Right double quote
    } else {
        LSQM <- RSQM <- "'"
        LDQM <- RDQM <- '"'
    }

    trim <- function(x) {
        x <- psub1("^\\s*", "", x)
        psub1("\\s*$", "", x)
    }

    striptitle <- function(text) {
        text <- fsub("\\", "", text)
        text <- fsub("---", "_", text)
        text <- fsub("--", "-", text)
        text
    }

    ## underline via backspacing
    txt_header <- function(header) {
        opts <- Rd2txt_options()
        header <- paste(strwrap(header, WIDTH), collapse="\n")
        if (opts$underline_titles) {
            letters <- strsplit(header, "", fixed = TRUE)[[1L]]
            isaln <- grep("[[:alnum:]]", letters)
            letters[isaln] <- paste0("_\b", letters[isaln])
            paste(letters, collapse = "")
        } else header
    }

    unescape <- function(x) {
        x <- psub("(---|--)", "-", x)
        x
    }

    writeCode <- function(x) {
        txt <- as.character(x)
        if(inEqn) txt <- txt_eqn(txt)
        txt <- fsub('"\\{"', '"{"', txt)
        ## \dots gets left in noquote.Rd
        txt <- fsub("\\dots",  "...", txt)
        put(txt)
    }

    # This function strips pending blank lines, then adds n new ones.
    blankLine <- function(n = 1L) {
    	while (length(buffer) &&
               grepl("^[[:blank:]]*$", buffer[length(buffer)]))
    	    buffer <<- buffer[-length(buffer)]
	flushBuffer()
	if (n > haveBlanks) {
	    buffer <<- rep_len("", n - haveBlanks)
	    flushBuffer()
	    haveBlanks <<- n
	}
	dropBlank <<- TRUE
    }

    txt_eqn <- function(x) {
        x <- psub("\\\\(Alpha|Beta|Gamma|Delta|Epsilon|Zeta|Eta|Theta|Iota|Kappa|Lambda|Mu|Nu|Xi|Omicron|Pi|Rho|Sigma|Tau|Upsilon|Phi|Chi|Psi|Omega|alpha|beta|gamma|delta|epsilon|zeta|eta|theta|iota|kappa|lambda|mu|nu|xi|omicron|pi|rho|sigma|tau|upsilon|phi|chi|psi|omega|sum|prod|sqrt)", "\\1", x)
        x <- psub("\\\\(dots|ldots)", "...", x)
        x <- fsub("\\le", "<=", x)
        x <- fsub("\\ge", ">=", x)
        x <- fsub("\\infty", "Inf", x)
        ## FIXME: are these needed?
        x <- psub("\\\\(bold|strong|emph|var)\\{([^}]*)\\}", "\\2", x)
        x <- psub("\\\\(code|samp)\\{([^}]*)\\}", "'\\2'", x)
        x
    }

    writeDR <- function(block, tag) {
        if (length(block) > 1L) {
            putf('## Not run:\n')
            writeCodeBlock(block, tag)
            blankLine(0L)
            putf('## End(Not run)\n')
        } else {
            putf('## Not run: ')
            writeCodeBlock(block, tag)
            blankLine(0L)
        }
    }

    writeQ <- function(block, tag, quote=tag)
    {
        if (use_fancy_quotes) {
            if (quote == "\\sQuote") {
                put(LSQM); writeContent(block, tag); put(RSQM)
            } else {
                put(LDQM); writeContent(block, tag); put(RDQM)
            }
        } else {
            if (quote == "\\sQuote") {
                put("'"); writeContent(block, tag); put("'")
            } else {
                put("\""); writeContent(block,tag); put("\"")
            }
        }
    }

    writeBlock <- function(block, tag, blocktag) {
        switch(tag,
               UNKNOWN =,
               VERB =,
               RCODE = writeCode(tabExpand(block)),
               TEXT = if(blocktag == "\\command") putw(block) else putw(unescape(tabExpand(block))),
               USERMACRO =,
               "\\newcommand" =,
               "\\renewcommand" =,
               COMMENT = {},
               LIST = writeContent(block, tag),
               "\\describe" = {
               	   blankLine(0L)
                   writeContent(block, tag)
                   blankLine()
               },
               "\\itemize"=,
               "\\enumerate"= {
               	   blankLine(0L)
                   enumItem0 <- enumItem
                   enumItem <<- 0L
                   indent0 <- indent
                   opts <- Rd2txt_options()
                   indent <<- max(opts$minIndent,
                              indent + opts$extraIndent)
                   dropBlank <<- TRUE
                   writeContent(block, tag)
                   blankLine()
                   indent <<- indent0
                   enumItem <<- enumItem0
               },
               "\\code"=,
               "\\command"=,
               "\\env"=,
               "\\file"=,
               "\\kbd"=,
               "\\option"=,
               "\\pkg"=,
               "\\samp" = {
                   opts <- Rd2txt_options()
                   if(opts$code_quote)
                       writeQ(block, tag, quote="\\sQuote")
                   else writeContent(block,tag)
               },
               "\\email"=  put("<email: ",
                               gsub("\n", "", paste(as.character(block), collapse="")),
                               ">"),
               "\\url"= put("<URL: ",
                              gsub("\n", "", paste(as.character(block), collapse="")),
                              ">") ,
               "\\href"= {
                   opts <- Rd2txt_options()
                   writeContent(block[[2L]], tag)
                   if (opts$showURLs)
  			put(" (URL: ",
  			    gsub("\n", "", paste(as.character(block[[1L]]), collapse="")),
  			    ")")
               },
               "\\Sexpr"= put(as.character.Rd(block, deparse=TRUE)),
               "\\acronym" =,
               "\\cite"=,
               "\\dfn"= ,
               "\\special" = ,
               "\\var" = writeContent(block, tag),

               "\\bold"=,
               "\\strong"= {
                   put("*")
                   writeContent(block, tag)
                   put("*")
               },
               "\\emph"= {
                   put("_")
                   writeContent(block, tag)
                   put("_")
               },
               "\\sQuote" =,
               "\\dQuote"= writeQ(block, tag) ,
               "\\preformatted"= {
                   putf("\n")
                   writeCodeBlock(block, tag)
               },
               "\\verb"= put(block),
               "\\linkS4class" =,
               "\\link" = writeContent(block, tag),
               "\\cr" = {
                   ## we want to print out what we have, and if
                   ## followed immediately by \n (as it usually is)
                   ## discard that.  This is not entirely correct,
                   ## but it is better than before ....
                   flushBuffer()
                   dropBlank <<- TRUE
                   },
               "\\dots" =,
               "\\ldots" = put("..."),
               "\\R" = put("R"),
               "\\enc" = {
                   ## Test to see if we can convert the encoded version
                   txt <- as.character(block[[1L]])
                   test <- iconv(txt, "UTF-8", outputEncoding, mark = FALSE)
                   txt <- if(!is.na(test)) txt else as.character(block[[2L]])
                   put(txt)
               } ,
               "\\eqn" = {
                   block <- block[[length(block)]]
                   ## FIXME: treat 2 of 2 differently?
                   inEqn0 <- inEqn
                   inEqn <<- TRUE
                   writeContent(block, tag)
                   inEqn <<- inEqn0
               },
               "\\deqn" = {
                   blankLine()
                   block <- block[[length(block)]]
                   save <- startCapture()
                   inEqn <<- TRUE
                   writeContent(block, tag)
                   eqn <- endCapture(save)
                   eqn <- frmt(eqn, justify="centre", width=WIDTH-indent)
                   putf(paste(eqn, collapse="\n"))
    		   blankLine()
               },
               "\\figure" = {
                   blankLine()
                   save <- startCapture()
                   writeContent(block[[length(block)]], tag)
                   alt <- endCapture(save)
                   if (length(alt)) {
                   	alt <- frmt(alt, justify = "centre",
                                    width = WIDTH - indent)
                   	putf(paste(alt, collapse = "\n"))
                   	blankLine()
                   }
               },
               "\\tabular" = writeTabular(block),
               "\\subsection" = writeSection(block, tag),
               "\\if"=,
               "\\ifelse" =
                   if (testRdConditional("text", block, Rdfile))
               		writeContent(block[[2L]], tag)
               	   else if (tag == "\\ifelse")
               	   	writeContent(block[[3L]], tag),
               "\\out" = for (i in seq_along(block))
		   put(block[[i]]),
               stopRd(block, Rdfile, "Tag ", tag, " not recognized")
               )
    }

    writeTabular <- function(table) {
    	formats <- table[[1L]]
    	content <- table[[2L]]
    	if (length(formats) != 1L || RdTags(formats) != "TEXT")
    	    stopRd(table, Rdfile, "\\tabular format must be simple text")
    	formats <- strsplit(formats[[1L]], "", fixed = TRUE)[[1L]]
        tags <- RdTags(content)
        entries <- list()
        row <- 1L
        col <- 1L
        save <- startCapture()
        dropBlank <<- TRUE
        newEntry <- function() {
            entries <<- c(entries, list(list(text=trim(endCapture(save)),
	                   	             row=row, col=col)))
            save <<- startCapture()
            dropBlank <<- TRUE
        }
        for (i in seq_along(tags)) {
            switch(tags[i],
                  "\\tab" = {
                  	newEntry()
                   	col <- col + 1
                   	if (col > length(formats))
                   	    stopRd(content[[i]], Rdfile,
                                   sprintf("too many columns for format '%s'",
                                           table[[1L]]))
                   },
                   "\\cr" = {
                   	newEntry()
                   	row <- row + 1L
			col <- 1L
                    },
                   writeBlock(content[[i]], tags[i], "\\tabular")
                   )
        }
        newEntry()
        endCapture(save)
        entries <- with(entries[[length(entries)]],
        	    {
                        if (!length(text) && col == 1L)
                            entries[-length(entries)]
                        else
                            entries
                    })
        rows <- entries[[length(entries)]]$row
        cols <- max(sapply(entries, function(e) e$col))
        widths <- rep_len(0L, cols)
        lines <- rep_len(1L, rows)
        for (i in seq_along(entries)) {
            e <- entries[[i]]
            while(length(e$text) && !nzchar(e$text[length(e$text)])) {
            	e$text <- e$text[-length(e$text)]
            	entries[[i]] <- e
            }
            if (any(nzchar(e$text)))
            	widths[e$col] <- max(widths[e$col], max(nchar(e$text, "w")))
            lines[e$row] <- max(lines[e$row], length(e$text))
        }
        result <- matrix("", sum(lines), cols)
        for (i in seq_len(cols))
            result[, i] <- blanks(widths[i])
        firstline <- c(1L, 1L+cumsum(lines))
        for (i in seq_along(entries)) {
            e <- entries[[i]]
            if(!length(e$text)) next
            ## FIXME: this is not right: it justifies strings as if
            ## they are escaped, so in particular \ takes two columns.
            text <- frmt(e$text, justify=formats[e$col], width=widths[e$col])
            for (j in seq_along(text))
            	result[firstline[e$row] + j - 1L, e$col] <- text[j]
        }
        blankLine()
        indent0 <- indent
        indent <<- indent + 1L
        for (i in seq_len(nrow(result))) {
            putf(paste0(" ", result[i,], " ", collapse=""))
# This version stripped leading blanks on the first line
#            for (j in seq_len(cols))
#            	putf(" ", result[i,j], " ")
            putf("\n")
        }
        blankLine()
        indent <<- indent0
    }

    writeCodeBlock <- function(blocks, blocktag)
    {
    	tags <- RdTags(blocks)
	i <- 0
	while (i < length(tags)) {
	    i <- i + 1
            block <- blocks[[i]]
            tag <- tags[i]
            switch(tag,
                   "\\method" =,
                   "\\S3method" =,
                   "\\S4method" = {
                   	blocks <- transformMethod(i, blocks, Rdfile)
                   	tags <- RdTags(blocks)
                   	i <- i - 1
                   },
                   UNKNOWN =,
                   VERB =,
                   RCODE =,
                   TEXT = writeCode(tabExpand(block)),
                   "\\donttest" =,
                   "\\special" =,
                   "\\var" = writeCodeBlock(block, tag),
                   "\\dots" =, # \ldots is not really allowed
                   "\\ldots" = put("..."),
                   "\\dontrun"= writeDR(block, tag),
		   USERMACRO =,
		   "\\newcommand" =,
		   "\\renewcommand" =,
                   COMMENT =,
                   "\\dontshow" =,
                   "\\testonly" = {}, # do nothing
                   ## All the markup such as \emph
                   stopRd(block, Rdfile, "Tag ", tag,
                          " not expected in code block")
                   )
        }
    }

    writeContent <- function(blocks, blocktag) {
        itemskip <- FALSE
	tags <- RdTags(blocks)

	for (i in seq_along(tags)) {
            tag <- tags[i]
            block <- blocks[[i]]
            switch(tag,
                   "\\item" = {
                       switch(blocktag,
                              "\\describe"= {
                                  blankLine()
                                  save <- startCapture()
                                  dropBlank <<- TRUE
                                  writeContent(block[[1L]], tag)
                                  DLlab <- endCapture(save)
                                  indent0 <- indent
                                  opts <- Rd2txt_options()
                                  indent <<- max(opts$minIndent,
                                                 indent + opts$extraIndent)
                                  keepFirstIndent <<- TRUE
                                  putw(paste(rep_len(" ", indent0), collapse=""),
                                       frmt(paste0(DLlab),
                                            justify="left", width=indent),
                                       " ")
                                  writeContent(block[[2L]], tag)
			  	  blankLine(0L)
                                  indent <<- indent0
                              },
                              "\\value"=,
                              "\\arguments"= {
                                  blankLine()
                                  save <- startCapture()
                                  dropBlank <<- TRUE
                                  writeContent(block[[1L]], tag)
                                  DLlab <- endCapture(save)
                                  indent0 <- indent
                                  opts <- Rd2txt_options()
                                  indent <<- max(opts$minIndent, indent + opts$extraIndent)
                                  keepFirstIndent <<- TRUE
                                  putw(frmt(paste0(DLlab, ": "),
                                              justify="right", width=indent))
                                  writeContent(block[[2L]], tag)
			  	  blankLine(0L)
                                  indent <<- indent0
                              },
                              "\\itemize" =,
                              "\\enumerate" = {
                              	  blankLine()
                              	  keepFirstIndent <<- TRUE
                              	  opts <- Rd2txt_options()
                              	  if (blocktag == "\\itemize")
                              	      label <- opts$itemBullet
                              	  else {
                              	      enumItem <<- enumItem + 1L
                              	      label <- opts$enumFormat(enumItem)
                              	  }
                              	  putw(frmt(label, justify="right",
                                            width=indent))
                              })
                       itemskip <- TRUE
                   },
               { # default
                   if (itemskip) {
                       ## The next item must be TEXT, and start with a space.
                       itemskip <- FALSE
                       if (tag == "TEXT") {
                           txt <- psub("^ ", "", as.character(tabExpand(block)))
                           put(txt)
                       } else writeBlock(block, tag, blocktag) # should not happen
                   } else writeBlock(block, tag, blocktag)
               })
	}
    }

    writeSection <- function(section, tag) {
        if (tag %in% c("\\alias", "\\concept", "\\encoding", "\\keyword"))
            return()
    	save <- c(indent, sectionLevel, keepFirstIndent, dropBlank, wrapping)
    	blankLine(min(sectionLevel, 1L))
    	titlePrefix <- paste(rep("  ", sectionLevel), collapse="")
    	opts <- Rd2txt_options()
        indent <<- opts$sectionIndent + opts$sectionExtra*sectionLevel
        sectionLevel <<- sectionLevel + 1
        keepFirstIndent <<- TRUE
        if (tag == "\\section" || tag == "\\subsection") {
            ## section header could have markup
            title <- .Rd_format_title(.Rd_get_text(section[[1L]]))
            putf(titlePrefix, txt_header(title), ":")
            blankLine()
            dropBlank <<- TRUE
            wrapping <<- TRUE
            keepFirstIndent <<- FALSE
    	    writeContent(section[[2L]], tag)
    	} else if (tag %in% c("\\usage", "\\examples")) {
            putf(txt_header(sectionTitles[tag]), ":")
            blankLine()
            dropBlank <<- TRUE
            wrapping <<- FALSE
            keepFirstIndent <<- FALSE
            writeCodeBlock(section, tag)
    	} else {
            putf(txt_header(sectionTitles[tag]), ":")
            blankLine()
            dropBlank <<- TRUE
            wrapping <<- TRUE
            keepFirstIndent <<- FALSE
            writeContent(section, tag)
        }
        blankLine()

        indent <<- save[1L]
        sectionLevel <<- save[2L]
        keepFirstIndent <<- save[3L]
        dropBlank <<- save[4L]
        wrapping <<- save[5L]
    }

    if (is.character(out)) {
        if(out == "") {
            con <- stdout()
        } else {
	    con <- file(out, "wt")
	    on.exit(close(con), add=TRUE)
	}
    } else {
    	con <- out
    	out <- summary(con)$description
    }

    Rd <- prepare_Rd(Rd, defines=defines, stages=stages, fragment=fragment, ...)
    Rdfile <- attr(Rd, "Rdfile")
    sections <- RdTags(Rd)
    if (fragment) {
    	if (sections[1L] %in% names(sectionOrder))
    	    for (i in seq_along(sections))
    	    	writeSection(Rd[[i]], sections[i])
    	else
    	    for (i in seq_along(sections))
    	    	writeBlock(Rd[[i]], sections[i], "")
    } else {
	title <- .Rd_format_title(.Rd_get_title(Rd))

	name <- trim(Rd[[2L]][[1L]])

	if(nzchar(package)) {
	    left <- name
	    mid <- if(nzchar(package)) paste0("package:", package) else ""
	    right <- "R Documentation"
	    if(encoding != "unknown")
		right <- paste0(right, "(", encoding, ")")
	    pad <- max(HDR_WIDTH - nchar(left, "w") - nchar(mid, "w") - nchar(right, "w"), 0)
	    pad0 <- pad %/% 2L
	    pad1 <- paste(rep.int(" ", pad0), collapse = "")
	    pad2 <- paste(rep.int(" ", pad - pad0), collapse = "")
	    putf(paste0(left, pad1, mid, pad2, right, "\n\n"))
	}

	putf(txt_header(title))
	blankLine()

	for (i in seq_along(sections)[-(1:2)])
	    writeSection(Rd[[i]], sections[i])
    }
    blankLine(0L)
    invisible(out)
}
#  File src/library/tools/R/RdConv2.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/


RdTags <- function(Rd) {
    res <- sapply(Rd, attr, "Rd_tag")
    if (!length(res)) res <- character()
    res
}

isBlankRd <- function(x)
    length(grep("^[[:blank:]]*\n?$", x, perl = TRUE)) == length(x) # newline optional

isBlankLineRd <- function(x) {
    attr(x, "srcref")[2L] == 1 &&
    length(grep("^[[:blank:]]*\n", x, perl = TRUE)) == length(x)   # newline required
}

stopRd <- function(block, Rdfile, ...)
{
    srcref <- attr(block, "srcref")
    if (missing(Rdfile) && !is.null(srcref)) {
    	srcfile <- attr(srcref, "srcfile")
    	if (is.environment(srcfile))
    	    Rdfile <- srcfile$filename
    }
    if (missing(Rdfile) || is.null(Rdfile)) Rdfile <- ""
    else Rdfile <- paste0(Rdfile, ":")

    msg <- if (is.null(srcref))
        paste0(Rdfile, " ", ...)
    else {
    	loc <- paste0(Rdfile, srcref[1L])
    	if (srcref[1L] != srcref[3L]) loc <- paste0(loc, "-", srcref[3L])
    	paste0(loc, ": ", ...)
    }
    stop(msg, call. = FALSE, domain = NA)
}

warnRd <- function(block, Rdfile, ...)
{
    srcref <- attr(block, "srcref")
    if (missing(Rdfile) && !is.null(srcref)) {
    	srcfile <- attr(srcref, "srcfile")
    	if (is.environment(srcfile))
    	    Rdfile <- srcfile$filename
    }
    if (missing(Rdfile) || is.null(Rdfile)) Rdfile <- ""
    else Rdfile <- paste0(Rdfile, ":")

    msg <- if (is.null(srcref))
        paste0(Rdfile, " ", ...)
    else {
    	loc <- paste0(Rdfile, srcref[1L])
    	if (srcref[1L] != srcref[3L]) loc <- paste0(loc, "-", srcref[3L])
        paste0(loc, ": ", ...)
    }
    warning(msg, call. = FALSE, domain = NA, immediate. = TRUE)
}

RweaveRdDefaults <- list(
    width = 6,
    height = 6,
    eval = TRUE,
    fig = FALSE,
    echo = FALSE,
    keep.source = TRUE,
    results = "text",
    strip.white = "true",
    stage = "install")

RweaveRdOptions <- function(options)
{

    ## convert a character string to logical
    c2l <- function(x){
        if(is.null(x)) return(FALSE)
        else return(as.logical(toupper(as.character(x))))
    }

    NUMOPTS <- c("width", "height")
    NOLOGOPTS <- c(NUMOPTS, "results", "stage", "strip.white")

    for(opt in names(options)){
        if(! (opt %in% NOLOGOPTS)){
            oldval <- options[[opt]]
            if(!is.logical(options[[opt]])){
                options[[opt]] <- c2l(options[[opt]])
            }
            if(is.na(options[[opt]]))
                stop(gettextf("invalid value for '%s' : %s", opt, oldval),
                     domain = NA)
        }
        else if(opt %in% NUMOPTS){
            options[[opt]] <- as.numeric(options[[opt]])
        }
    }

    if(!is.null(options$results))
        options$results <- tolower(as.character(options$results))
    options$results <- match.arg(options$results,
                                 c("text", "verbatim", "rd", "hide"))
    if(!is.null(options$stage))
    	options$stage <- tolower(as.character(options$stage))
    options$stage <- match.arg(options$stage,
    				 c("build", "install", "render"))
    options
}

tagged <- function(x, tag) structure(x, Rd_tag=tag)

evalWithOpt <- function(expr, options, env)
{
    res <- structure("", Rd_tag="COMMENT")
    if(options$eval){
        result <- tryCatch(withVisible(eval(expr, env)), error=function(e) e)

        if(inherits(result, "error")) return(result)
        switch(options$results,
        "text" = if (result$visible)
		    res <- paste(as.character(result$value), collapse=" "),
        "verbatim" = if (result$visible) print(result$value),
        "rd" = res <- result$value)
    }
    return(res)
}

# The parser doesn't distinguish between types of Sexprs, we do
expandDynamicFlags <- function(block, options = RweaveRdDefaults) {
    recurse <- function(block) {
	flags <- getDynamicFlags(block)
	if (flags["\\Sexpr"]) {
	    if (identical(tag <- attr(block, "Rd_tag"), "\\Sexpr")) {
		if (is.null(opts <- attr(block, "Rd_option"))) opts <- ""
		# modify locally
                options <- utils:::SweaveParseOptions(opts, options, RweaveRdOptions)
                flags[options$stage] <- TRUE
	    } else if (identical(tag, "\\RdOpts")) {
	        # modify globally
	    	options <<- utils:::SweaveParseOptions(block, options, RweaveRdOptions)
	    } else { # Has \Sexpr flag, so must be a list
		for (i in seq_along(block)) {
		    block[[i]] <- recurse(block[[i]])
		    flags <- flags | getDynamicFlags(block[[i]])
		}
	    }
	    block <- setDynamicFlags(block, flags)
	}
	block
    }
    recurse(block)
}

getDynamicFlags <- function(block) {
    flag <- attr(block, "dynamicFlag")
    if (is.null(flag)) c("#ifdef"=FALSE, "\\Sexpr"=FALSE, build=FALSE, install=FALSE, render=FALSE)
    else c("#ifdef" = flag %% 2L > 0L,               # 1
           "\\Sexpr" = (flag %/% 2L) %% 2L > 0L,     # 2
           build = (flag %/% 4L) %% 2L > 0L,         # 4
           install = (flag %/% 8L) %% 2L > 0L,       # 8
           render = (flag %/% 16L) %% 2L > 0L)       # 16
}

setDynamicFlags <- function(block, flags) {  # flags in format coming from getDynamicFlags
    flag <- sum(flags * c(1L,2L,4L,8L,16L))
    if (flag == 0L) flag <- NULL
    attr(block, "dynamicFlag") <- flag
    block
}

processRdChunk <- function(code, stage, options, env, Rdfile)
{
    if (is.null(opts <- attr(code, "Rd_option"))) opts <- ""
    codesrcref <- attr(code, "srcref")
    options <- utils:::SweaveParseOptions(opts, options, RweaveRdOptions)
    if (stage == options$stage) {
        #  The code below is very similar to RWeaveLatexRuncode, but simplified

        # Results as a character vector for now; convert to list later
        res <- character(0)
        code <- code[RdTags(code) != "COMMENT"]
	chunkexps <- tryCatch(parse(text = code), error = identity)
	if (inherits(chunkexps, "error")) stopRd(code, Rdfile, chunkexps)

	if(length(chunkexps) == 0L)
	    return(tagged(code, "LIST"))

	srcrefs <- attr(chunkexps, "srcref")
	lastshown <- 0L
	thisline <- 0
	err <- NULL
	for(nce in seq_along(chunkexps))
	{
	    ce <- chunkexps[[nce]]
	    if (nce <= length(srcrefs) && !is.null(srcref <- srcrefs[[nce]])) {
		srcfile <- attr(srcref, "srcfile")
		showfrom <- srcref[1L]
		showto <- srcref[3L]
		dce <- getSrcLines(srcfile, lastshown+1, showto)
		leading <- showfrom-lastshown
		lastshown <- showto
		while (length(dce) && grepl("^[[:blank:]]*$", dce[1L])) {
		    dce <- dce[-1L]
		    leading <- leading - 1L
		}
	    } else {
		dce <- deparse(ce, width.cutoff=0.75*getOption("width"))
		leading <- 1L
	    }
	    if(options$echo && length(dce)) {
		res <- c(res,"\n",
                         paste(getOption("prompt"), dce[1L:leading],
                               sep="", collapse="\n"))
		if (length(dce) > leading)
		    res <- c(res, "\n",
                             paste(getOption("continue"), dce[-(1L:leading)],
                                   sep="", collapse="\n"))
		thisline <- thisline + length(dce)
	    }

	    tmpcon <- file()
	    sink(file = tmpcon)
	    if(options$eval) err <- evalWithOpt(ce, options, env)
	    res <- c(res, "\n") # make sure final line is complete
	    sink()
	    output <- readLines(tmpcon)
	    close(tmpcon)
	    ## delete empty output
	    if(length(output) == 1L & output[1L] == "") output <- NULL

	    if (inherits(err, "error")) {
	    	attr(code, "srcref") <- codesrcref
	    	stopRd(code, Rdfile, err$message)
	    }

	    if(length(output) & (options$results != "hide")){

		output <- paste(output, collapse="\n")
		if(options$strip.white %in% c("all", "true")) {
		    output <- sub("^[[:space:]]*\n", "", output)
		    output <- sub("\n[[:space:]]*$", "", output)
		    if(options$strip.white == "all")
		      output <- sub("\n[[:space:]]*\n", "\n", output)
		}
		res <- c(res, output)
		remove(output)
	    }
	}
	if (options$results == "rd") {
	    res <- as.character(err)   # The last value of the chunk
	    tmpcon <- file()
	    writeLines(res, tmpcon, useBytes = TRUE)
	    parseFragment <- function(cond) {
	    	               seek(tmpcon, 0)
	    	               parse_Rd(tmpcon, fragment=TRUE)
	    	            }
	    res <- tryCatch(parse_Rd(tmpcon, fragment=FALSE),
	    	            warning = parseFragment, error = parseFragment,
	    	            finally = close(tmpcon))
	    # Now remove that extra newline added by the writeLines
	    last <- res[[length(res)]]
	    if (attr(last, "Rd_tag") == "TEXT" && (len <- length(last)))
	        res[[length(res)]][len] <- gsub("\\n$", "", last[len])
	    flag <- getDynamicFlags(res)
	    # We may have multiple chunks now.  If they are in
	    # a section, we can wrap them in LIST, but at top
	    # level we can't, so we disallow multiple sections.

	    # First clear out the junk.
	    tags <- RdTags(res)
	    keep <- rep(TRUE, length(tags))
	    for (i in seq_along(tags)) {
	        if (tags[i] == "TEXT" && res[[i]] == "")
	            keep[i] <- FALSE
	    }
	    res <- res[keep]
	    tags <- tags[keep]
	    if (length(res) > 1) {
	    	is_section <- !is.na(sectionOrder[tags])
	    	if (!any(is_section))
	    	    res <- tagged(res, "LIST")
	    	else {
	    	    if (sum(is_section) > 1)
	    		stop(gettextf("Only one Rd section per %s is supported.",
                                      "\\Sexpr"),
                             domain = NA)
	    	    res <- res[[which(is_section)]]
	    	}
	    } else if (length(res) == 1) res <- res[[1]]
	    else res <- tagged("", "TEXT")

	    if (is.list(res)) {
	    	res <- setDynamicFlags(res, flag)
	    	res <- prepare_Rd(res, defines = .Platform$OS.type, options=options,
	                           stage2 = FALSE, stage3 = FALSE)
	    }
	} else if (options$results == "text")
	    res <- tagged(err, "TEXT")
	else if (length(res)) {
	    res <- lapply(as.list(res), function(x) tagged(x, "VERB"))
	    res <- tagged(res, "\\verb")
	} else res <- tagged("", "COMMENT")
    } else res <- code
    attr(res, "srcref") <- codesrcref
    res
}

processRdIfdefs <- function(blocks, defines)
{
    recurse <- function(block) {
    	if (!(getDynamicFlags(block)["#ifdef"])) return(block)

        if (!is.null(tag <- attr(block, "Rd_tag"))) {
	    if (tag %in% c("#ifdef", "#ifndef")) {
		target <- block[[1L]][[1L]]
		# The target will have picked up some whitespace and a newline
		target <- psub("[[:blank:][:cntrl:]]*", "", target)
		if ((target %in% defines) == (tag == "#ifdef")) {
		    flag <- getDynamicFlags(block[[2L]])
		    block <- tagged(block[[2L]], "#expanded")
		    block <- setDynamicFlags(block, flag)
		} else
		    block <- structure(tagged(paste(tag, target, "not active"),
                                              "COMMENT"),
		    		       srcref = attr(block, "srcref"))
	    }
	}
	if (is.list(block)) {
	    i <- 1L
	    flags <- getDynamicFlags(NULL)
	    while (i <= length(block)) {
	    	newval <- recurse(block[[i]])
	    	newtag <- attr(newval, "Rd_tag")
	    	if (!is.null(newtag) && newtag == "#expanded") { # ifdef has expanded.
	    	    all <- seq_along(block)
	    	    before <- all[all < i]
	    	    after <- all[all > i]
	    	    block <- structure(tagged(c(block[before], newval, block[after]),
	    	    			      tag), srcref = attr(block, "srcref"))
	    	} else {
	    	    flags <- flags | getDynamicFlags(newval)
		    block[[i]] <- newval
		    i <- i+1L
		}
	    }
	    block <- setDynamicFlags(block, flags)
	}
	block
    }

    recurse(blocks)
}

processRdSexprs <-
    function(block, stage, options = RweaveRdDefaults,
             env = new.env(hash = TRUE, parent = globalenv()))
{
    recurse <- function(block) {
    	if (!any(getDynamicFlags(block)[stage])) return(block)

        if (is.list(block)) {
            if (!is.null(tag <- attr(block, "Rd_tag"))) {
        	if (tag == "\\Sexpr")
            	    block <- processRdChunk(block, stage, options, env)
            	else if (tag == "\\RdOpts")
    	    	    options <<-
                        utils:::SweaveParseOptions(block, options, RweaveRdOptions)
    	    }
    	    if (is.list(block)) {
		for (i in seq_along(block))
		    block[[i]] <- recurse(block[[i]])
	    }
	}
	block
    }

    if (!any(getDynamicFlags(block)[stage])) return(block)
    expandDynamicFlags(recurse(block), options)
}

prepare_Rd <-
    function(Rd, encoding = "unknown", defines = NULL, stages = NULL,
             fragment = FALSE, options = RweaveRdDefaults,
             stage2 = TRUE, stage3 = TRUE, ..., msglevel = 0)
{
    if (is.character(Rd)) {
        Rdfile <- Rd
        ## do it this way to get info in internal warnings
        Rd <- eval(substitute(parse_Rd(f, encoding = enc, fragment = frag, ...),
                              list(f = Rd, enc = encoding, frag = fragment)))
    } else if(inherits(Rd, "connection")) {
        Rdfile <- summary(Rd)
        Rd <- parse_Rd(Rd, encoding = encoding, fragment=fragment, ...)
    } else Rdfile <- attr(Rd, "Rdfile")
    srcref <- attr(Rd, "srcref")
    if (is.null(Rdfile) && !is.null(srcref))
    	Rdfile <- attr(srcref, "srcfile")$filename
    if (fragment) meta <- NULL
    else {
	pratt <- attr(Rd, "prepared")
	if (is.null(pratt)) pratt <- 0L
	if ("build" %in% stages)
	    Rd <- processRdSexprs(Rd, "build", options)
	if (!is.null(defines))
	    Rd <- processRdIfdefs(Rd, defines)
	for (stage in c("install", "render"))
	    if (stage %in% stages)
		Rd <- processRdSexprs(Rd, stage, options)
	if (pratt < 2L && stage2)
	    Rd <- prepare2_Rd(Rd, Rdfile)
	meta <- attr(Rd, "meta")
	if (pratt < 3L && stage3)
	    Rd <- prepare3_Rd(Rd, Rdfile, msglevel = msglevel)

	# Restore flags from any sections that are left
	Rd <- setDynamicFlags(Rd, apply(sapply(Rd, getDynamicFlags), 1, any))
    }
    structure(Rd, Rdfile = Rdfile, class = "Rd", meta = meta,
              srcref = srcref)
}

prepare2_Rd <- function(Rd, Rdfile)
{
    sections <- RdTags(Rd)

    ## FIXME: we no longer make any use of \Rdversion
    version <- which(sections == "\\Rdversion")
    if (length(version) > 1L)
    	stopRd(Rd[[version[2L]]], Rdfile,
               "Only one \\Rdversion declaration is allowed")

    ## Give warning (pro tem) for nonblank text outside a section
    if (length(bad <- grep("[^[:blank:][:cntrl:]]",
                           unlist(Rd[sections == "TEXT"]),
                           perl = TRUE, useBytes = TRUE )))
        for(s in bad)
            warnRd(Rd[sections == "TEXT"][[s]], Rdfile,
                   "All text must be in a section")

    drop <- rep.int(FALSE, length(sections))

    ## Check other sections are unique
    unique_tags <-
        paste("\\",
              c("usage", "arguments", "synopsis",
                "format", "details", "value", "references", "source",
                "seealso", "examples", "author", "encoding"),
              sep = "")
    for (tag in unique_tags) {
        where <- which(sections == tag)
        if(length(where) > 1L) {
            warnRd(Rd[where[[2L]]], Rdfile,
                   sprintf("Only one %s section is allowed: the first will be used", tag))
            drop[where[-1L]] <- TRUE
        }
    }

    enc <- which(sections == "\\encoding")
    if (length(enc)) {
    	encoding <- Rd[[enc]]
    	if (!identical(RdTags(encoding), "TEXT"))
    	    stopRd(encoding, Rdfile, "'encoding' must be plain text")
    }

    dt <- which(sections == "\\docType")
    docTypes <- character(length(dt))
    if(length(dt)) {
        if(length(dt) > 1L)
            warnRd(dt[[1L]], Rdfile,
                   "Multiple \\docType sections are not supported")
        for(i in seq_along(dt)) {
            docType <- Rd[[dt[i]]]
            if(!identical(RdTags(docType), "TEXT"))
        	stopRd(docType, Rdfile, "'docType' must be plain text")
            ## Some people have \docType{ package } and similar.
            docTypes[i] <- sub("^ *", "", sub(" *$", "", docType[[1L]]))
            if (! docTypes[i] %in%
                c("data", "package", "methods", "class"))
                warnRd(dt[i], Rdfile, "docType ", sQuote(docTypes[i]),
                       " is unrecognized")
         }
    }

    ## Drop all the parts that are not rendered
    extras <- c("COMMENT", "TEXT", "\\docType", "\\Rdversion", "\\RdOpts",
                "USERMACRO", "\\newcommand", "\\renewcommand")
    drop <- drop | (sections %in% extras)
    bad <- ! sections %in% c(names(sectionOrder), extras)
    if (any(bad)) {
        for(s in which(bad))
            warnRd(Rd[[s]], Rdfile, "Section ",
                   sections[s], " is unrecognized and will be dropped")
        drop <- drop | bad
    }
    Rd <- Rd[!drop]
    sections <- sections[!drop]
    sortorder <- order(sectionOrder[sections])
    Rd <- Rd[sortorder]
    sections <- sections[sortorder]
    if (!identical(sections[1:2], c("\\title", "\\name")))
    	stopRd(Rd, Rdfile,
               "Sections \\title, and \\name must exist and be unique in Rd files")
    if (length(RdTags(Rd[[2L]])) > 1L)
        stopRd(RdTags(Rd[[2L]]), Rdfile,"\\name must only contain simple text")

    ## R-exts points out that ! | @ cause problems in \name:
    ## ggplot2 demonstrated it
    name_text <- as.character(Rd[[2L]])
    if(grepl("[!|@]", name_text))
        warnRd(RdTags(Rd[[2L]]), Rdfile,"\\name should not contain !, | or @")
    ## is this really what we want?  docTypes is a vector.
    structure(Rd, meta = list(docType = docTypes))
}

prepare3_Rd <- function(Rd, Rdfile, msglevel = 0)
{
    ## Drop 'empty' sections: less rigorous than checkRd test
    keep <- rep(TRUE, length(Rd))
    checkEmpty <- function(x, this)
    {
        if(this) return(TRUE)
        if(is.list(x))
            for(xx in x) this <- checkEmpty(xx, this)
        else {
            tag <- attr(x, "Rd_tag")
            switch(tag,
		   USERMACRO =,
		   "\\newcommand" =,
		   "\\renewcommand" =,
		   COMMENT = {},
                   VERB =,
                   RCODE =,
                   TEXT = if(any(grepl("[^[:space:]]", s, perl = TRUE, useBytes=TRUE))) return(TRUE),
                   return(TRUE)
                   )
        }
        this
     }
    for (i in seq_along(Rd)) {
        this <- FALSE
        s0 <- section <- Rd[[i]]
        tag <- attr(section, "Rd_tag")
        if(tag == "\\section") {
            tagtitle <- sQuote(as.character(section[[1L]]))
            section <- section[[2L]]
        } else tagtitle <- tag
        for(s in section) this <- checkEmpty(s, this)
        keep[i] <- this
        if(!this && msglevel > 0)
            warnRd(s0, Rdfile, "Dropping empty section ", tagtitle)
    }
    Rd[keep]
}

sectionOrder <- c("\\title"=1, "\\name"=2, "\\alias"=2.1, "\\concept"=2.2,
                  "\\keyword"=2.3, "\\encoding"=2.4,
    "\\description"=3, "\\usage"=4, "\\arguments"=5,
    "\\format"=6, "\\details"=7, "\\value"=8, "\\section"=9,
    "\\note"=10, "\\author" = 11, "\\source"=12, "\\references"=13,
    "\\seealso"=14, "\\examples"=15)

sectionTitles <-
    c("\\description"="Description", "\\usage"="Usage",
      "\\arguments"="Arguments", "\\format"="Format", "\\details"="Details",
      "\\note"="Note", "\\section"="section", "\\author"="Author(s)",
      "\\references"="References", "\\source"="Source",
      "\\seealso"="See Also", "\\examples"="Examples", "\\value"="Value")

psub <- function(pattern, replacement, x)
##    gsub(pattern, replacement, x, perl = TRUE, useBytes = TRUE)
    .Internal(gsub(pattern, replacement, x, FALSE, TRUE, FALSE, TRUE))

psub1 <- function(pattern, replacement, x)
##    sub(pattern, replacement, x, perl = TRUE, useBytes = TRUE)
    .Internal(sub(pattern, replacement, x, FALSE, TRUE, FALSE, TRUE))

fsub <- function(pattern, replacement, x)
##    gsub(pattern, replacement, x, fixed = TRUE, useBytes = TRUE)
    .Internal(gsub(pattern, replacement, x, FALSE, FALSE, TRUE, TRUE))

fsub1 <- function(pattern, replacement, x)
##    sub(pattern, replacement, x, fixed = TRUE, useBytes = TRUE)
    .Internal(sub(pattern, replacement, x, FALSE, FALSE, TRUE, TRUE))


## for lists of messages, see ../man/checkRd.Rd
checkRd <- function(Rd, defines=.Platform$OS.type, stages = "render",
                    unknownOK = TRUE, listOK = TRUE, ..., def_enc = FALSE)
{
    warnRd <- function(block, Rdfile, ..., level=0)
    {
        srcref <- attr(block, "srcref")
        msg <- if (is.null(srcref))
            paste0("file '", Rdfile, "': ", ...)
        else {
            loc <- paste0(Rdfile, ":", srcref[1L])
            if (srcref[1L] != srcref[3L]) loc <- paste0(loc, "-", srcref[3L])
            paste0(loc, ": ", ...)
        }
        msg <- sprintf("checkRd: (%d) %s", level, msg)
        .messages <<- c(.messages, msg)
    }

    checkWrapped <- function(tag, block) checkContent(block, tag)

    checkLink <- function(tag, block) {
    	option <- attr(block, "Rd_option")
    	if(!is.null(option)) checkContent(option, tag)
    	checkContent(block, tag)
        get_link(block, tag, Rdfile) ## to do the same as Rd2HTML
    }

    ## blocktag is unused
    checkBlock <- function(block, tag, blocktag)
    {
	switch(tag,
               ## parser already warned here
               UNKNOWN = if (!unknownOK)
               stopRd(block, Rdfile, "Unrecognized macro ", block[[1L]]),
               VERB = ,
               RCODE = ,
               TEXT = {
                   if(!def_enc) {
                       ## check for encoding; this is UTF-8 if known
                       ## (but then def_enc = TRUE?)
                       msg2 <- if(inEnc2) "in second part of \\enc" else "without declared encoding"
                       if(Encoding(block) == "UTF-8")
                           warnRd(block, Rdfile, level = -1,
                                  "Non-ASCII contents ", msg2)
                       if(grepl("<[0123456789abcdef][0123456789abcdef]>", block))
                           warnRd(block, Rdfile, level = -3,
                                  "Apparent non-ASCII contents ", msg2)
                   }
                   ## check if this renders as non-whitespace
                   if(!grepl("^[[:space:]]*$", block)) has_text <<- TRUE
               },
               USERMACRO =,
               "\\newcommand" =,
               "\\renewcommand" =,
               COMMENT = {},
               LIST = if (length(block)) {
                   deparse <- sQuote(paste(as.character.Rd(block), collapse=""))
                   if(!listOK)
                       stopRd(block, Rdfile, "Unnecessary braces at ", deparse)
                   else warnRd(block, Rdfile, level = -3,
                               "Unnecessary braces at ", deparse)
                   checkContent(block, tag)
               },
               "\\describe"=,
               "\\enumerate"=,
               "\\itemize"=,
               "\\bold"=,
               "\\cite"=,
               "\\command"=,
               "\\dfn"=,
               "\\emph"=,
               "\\kbd"= checkContent(block, tag),
               "\\code"=,
               "\\preformatted"= checkCodeBlock(block, tag),
               "\\Sexpr"=,
               "\\special"=,
               "\\strong"=,
               "\\var" =,
               "\\verb"= checkContent(block, tag),
               "\\linkS4class" =,
               "\\link" = checkLink(tag, block),
               "\\email" =,
               "\\url" = has_text <<- TRUE,
               "\\cr" ={},
               "\\dots" =,
               "\\ldots" =,
               "\\R" = has_text <<- TRUE,
               "\\acronym" =,
               "\\env" =,
               "\\file" =,
               "\\option" =,
               "\\pkg" =,
               "\\samp" =,
               "\\sQuote" =,
               "\\dQuote" = checkContent(block, tag),
               "\\method" =,
               "\\S3method" =,
               "\\S4method" =
                   warnRd(block, Rdfile, level = 7, "Tag ", tag,
                          " not valid outside a code block"),
               "\\enc" = {
                   checkContent(block[[1L]], tag)
                   ## second arg should always be ASCII
                   save_enc <- def_enc
                   def_enc <<- FALSE
                   inEnc2 <<- TRUE
                   checkContent(block[[2L]], tag)
                   def_enc <<- save_enc
                   inEnc2 <<- FALSE
               },
               "\\eqn" =,
               "\\deqn" =,
               "\\figure" = {
                   checkContent(block[[1L]])
                   if (length(block) > 1L) checkContent(block[[2L]])
               },
               "\\tabular" = checkTabular(block),
               "\\subsection" = checkSection(block, tag),
               "\\if" =,
               "\\ifelse" = {
    		   condition <- block[[1L]]
    		   tags <- RdTags(condition)
    		   if (!all(tags %in% c("TEXT", "\\Sexpr")))
    		       stopRd(block, Rdfile, "Condition must be \\Sexpr or plain text")
    		   condition <- condition[tags == "TEXT"]
    		   allow <- .strip_whitespace(strsplit(paste(condition, collapse=""), ",")[[1L]])
    		   unknown <- allow[!(allow %in%
    		          c("", "latex", "example", "text", "html", "TRUE", "FALSE"))]
    		   if (length(unknown))
    		       warnRd(block, Rdfile, "Unrecognized format: ", unknown)
                   checkContent(block[[2L]])
                   if (tag == "\\ifelse")
                       checkContent(block[[3L]])
               },
               "\\href" = {
                   if (!identical(RdTags(block[[1L]]), "VERB"))
                   	stopRd(block, Rdfile, "First argument to \\href must be verbatim URL")
               	   checkContent(block[[2L]], tag)
               },
               "\\out" = {
               	   tags <- RdTags(block)
               	   if (!all(tags == "VERB"))
               	       stopRd(block, Rdfile, "Must contain verbatim text")
               },
               warnRd(block, Rdfile, level = 7, "Tag ", tag, " not recognized"))
    }

    checkCodeBlock <- function(blocks, blocktag)
    {
	for (block in blocks) {
            tag <- attr(block, "Rd_tag")
            switch(tag,
                   ## parser already warned here
                   UNKNOWN = if (!unknownOK)
                   stopRd(block, Rdfile, "Unrecognized macro ", block[[1L]]),
                   VERB = ,
                   RCODE = ,
                   TEXT = {
                       if(!def_enc) {
                           ## check for encoding; this is UTF-8 if known
                           ## (but then def_enc = TRUE?)
                           msg2 <- if(inEnc2) "in second part of \\enc" else "without declared encoding"
                           if(Encoding(block) == "UTF-8")
                               warnRd(block, Rdfile, level = -1,
                                      "Non-ASCII contents ", msg2)
                           if(grepl("<[0123456789abcdef][0123456789abcdef]>", block))
                               warnRd(block, Rdfile, level = -3,
                                      "Apparent non-ASCII contents ", msg2)
                       }
                       ## check if this renders as non-whitespace
                       if(!grepl("^[[:space:]]*$", block)) has_text <<- TRUE
                   },
		   USERMACRO =,
		   "\\newcommand" =,
		   "\\renewcommand" =,
                   COMMENT = {},
                   "\\var" = checkCodeBlock(block, blocktag), # not preformatted, but the parser checks that
                   "\\special" = checkCodeBlock(block, blocktag),
                   "\\dots" = has_text <<- TRUE,
                   "\\ldots" = {
                       ## but it is rendered as ... in all converters
                       warnRd(block, Rdfile, level = -3,
                              "Tag ", tag, " is invalid in a code block")
                       has_text <<- TRUE
                   },
                   ## these are valid in \code, at least
                   "\\linkS4class" =,
                   "\\link" = checkLink(tag, block),
                   "\\method" =,
                   "\\S3method" =,
                   "\\S4method" = if(blocktag == "\\usage") {
                       checkContent(block[[1L]], tag) # generic
                       checkContent(block[[2L]], tag) # class
                   } else warnRd(block, Rdfile, level = 7,
                                 "Tag ", tag, " is only valid in \\usage"),
                   "\\dontrun" =,
                   "\\donttest" =,
                   "\\dontshow" =,
                   "\\testonly" = if(blocktag == "\\examples")
                   checkCodeBlock(block, blocktag)
                   else warnRd(block, Rdfile, level = 7,
                               "Tag ", tag, " is only valid in \\examples"),
                   {
                       warnRd(block, Rdfile, level = 7,
                              "Tag ", tag, " is invalid in a ",
                              blocktag, " block")
                       has_text <<- TRUE  # likely, e.g. \url
                   })
        }
    }

    checkTabular <- function(table) {
        has_text <<- TRUE
    	format <- table[[1L]]
    	content <- table[[2L]]
    	if (length(format) != 1 || RdTags(format) != "TEXT")
    	    warnRd(table, Rdfile, level = 7,
                   "\\tabular format must be simple text")
    	format <- strsplit(format[[1L]], "", fixed=TRUE)[[1L]]
    	if (!all(format %in% c("l", "c", "r")))
    	    warnRd(table, Rdfile, level = 7,
                   "Unrecognized \\tabular format: ", table[[1L]][[1L]])
        tags <- RdTags(content)

        newrow <- TRUE
        for (i in seq_along(tags)) {
            if (newrow) {
            	newrow <- FALSE
            	col <- 0
            	newcol <- TRUE
            }
            if (newcol) {
                col <- col + 1
                if (col > length(format))
                    warnRd(table, Rdfile, level = 7,
                           "Only ", length(format),
                           " columns allowed in this table")
            	newcol <- FALSE
            }
            switch(tags[i],
            "\\tab" = {
            	newcol <- TRUE
            },
            "\\cr" = {
            	newrow <- TRUE
            },
            checkBlock(content[[i]], tags[i], "\\tabular"))
        }
    }

    checkContent <- function(blocks, blocktag) {
        inlist <- FALSE

	tags <- RdTags(blocks)

	for (i in seq_along(tags)) {
            tag <- tags[i]
            block <- blocks[[i]]
            switch(tag,
            "\\item" = {
    	    	if (!inlist) inlist <- TRUE
    		switch(blocktag,
    		"\\arguments"= {
    		    checkContent(block[[1L]], tag)
    		    checkContent(block[[2L]], tag)
    		},
    		"\\value"=,
    		"\\describe"= {
    		    checkContent(block[[1L]], tag)
    		    checkContent(block[[2L]], tag)
    		},
    		"\\enumerate"=,
    		"\\itemize"= {})
    	    },
    	    { # default
    	    	if (inlist && !(blocktag %in% c("\\itemize", "\\enumerate"))
    	    	           && !(tag == "TEXT" && isBlankRd(block))) {
    		    inlist <- FALSE
    		}
    		checkBlock(block, tag, blocktag)
    	    })
	}
    }

    has_text <- FALSE
    checkSection <- function(section, tag) {
    	if (tag == "\\section" || tag == "\\subsection") {
    	    title <- section[[1L]]
    	    checkContent(title, tag)
    	    section <- section[[2L]]
            ## replace 'tag' in message below
            tagtitle <- sQuote(as.character(title))
    	} else tagtitle <- tag
        has_text <<- FALSE
        if (tag == "\\synopsis")
            stopRd(section, Rdfile, "\\synopsis was removed in R 3.1.0")
        if (tag %in% c("\\usage", "\\examples"))
            checkCodeBlock(section, tag)
    	else checkContent(section, tag)
        if(!has_text) warnRd(section, Rdfile, level = 3,
                             "Empty section ", tagtitle)
    }

    checkUnique <- function(tag) { # currently only used for \description
    	which <- which(sections == tag)
    	if (length(which) < 1L)
    	    warnRd(Rd, Rdfile, level = 5, "Must have a ", tag)
    	else {
            if (length(which) > 1L)
    	    	warnRd(Rd[[which[2L]]], Rdfile, level = 5,
                   "Only one ", tag, " is allowed")
            empty <- TRUE
            for(block in Rd[which]) {
                switch(attr(block, "Rd_tag"),
                       TEXT = if(!grepl("^[[:space:]]*$", block))
                       empty <- FALSE,
                       empty <- FALSE)
            }
            if(empty)
                warnRd(Rd[[which[1L]]], Rdfile, level = 5,
                       "Tag ", tag, " must not be empty")
        }
    }

    dt <- which(RdTags(Rd) == "\\docType")
    docTypes <- character(length(dt))
    if (length(dt)) {
        for (i in dt) {
            docType <- Rd[[i]]
            if(!identical(RdTags(docType), "TEXT"))
        	warnRd(docType, Rdfile, level = 7,
                       "'docType' must be plain text")
            ## Some people have \docType{ package } and similar.
            docTypes[i] <- sub("^ *", "", sub(" *$", "", docType[[1L]]))
         }
    }

    .messages <- character()
    .whandler <-     function(e) {
        .messages <<- c(.messages, paste("prepare_Rd:", conditionMessage(e)))
        invokeRestart("muffleWarning")
    }

    Rd <- withCallingHandlers({
        prepare_Rd(Rd, defines=defines, stages=stages,
                   warningCalls = FALSE, ..., msglevel = 1)
    }, warning = .whandler)
    Rdfile <- attr(Rd, "Rdfile")
    sections <- RdTags(Rd)

    enc <- which(sections == "\\encoding")
    ## sanity was checked in prepare2_Rd
    if (length(enc)) def_enc <- TRUE

    inEnc2 <- FALSE
    if(!identical("package", docTypes))
        checkUnique("\\description")

    ## Check other standard sections are unique
    ## \alias, \keyword and \note are allowed to be repeated
    ## Normally prepare_Rd will have dropped duplicates already
    unique_tags <-
        paste("\\",
              c("name", "title", # "description" checked above
                "usage", "arguments",  "synopsis",
                "format", "details", "value", "references", "source",
                "seealso", "examples", "author", "encoding"),
              sep = "")
    for(tag in intersect(sections[duplicated(sections)], unique_tags))
        warnRd(Rd, Rdfile, level = 5,
               sprintf("multiple sections named '%s' are not allowed", tag))

    for (i in seq_along(sections))
        checkSection(Rd[[i]], sections[i])

    structure(.messages, class = "checkRd")
}

print.checkRd <- function(x, minlevel = -Inf, ...)
{
    fromParse <- grepl("^prepare_Rd", x)
    x1 <- x[fromParse]
    x2 <- x[!fromParse]
    levs <- as.numeric(sub("^checkRd: \\(([-0123456789]+)(.*)", "\\1", x2))
    xx <- if(minlevel > 0) x2[levs >= minlevel] else c(x1, x2[levs >= minlevel])
    writeLines(unique(xx))
    invisible(x)
}

testRdConditional <- function(format, conditional, Rdfile) {
    condition <- conditional[[1L]]
    tags <- RdTags(condition)
    if (!all(tags == "TEXT")) stopRd(conditional, Rdfile, "condition must be plain text")

    allow <- .strip_whitespace(strsplit(paste(condition, collapse=""), ",")[[1L]])
    any(c("TRUE", format) %in% allow)
}

toRd <- function(obj, ...)
    UseMethod("toRd")

toRd.default <- function(obj, ...) {
    obj <- as.character(obj)
    obj <- gsub("\\", "\\\\", obj, fixed = TRUE)
    obj <- gsub("{", "\\{", obj, fixed = TRUE)
    obj <- gsub("}", "\\}", obj, fixed = TRUE)
    gsub("%", "\\%", obj, fixed = TRUE)
}
#  File src/library/tools/R/Rdtools.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/


RdTextFilter <-
function(ifile, encoding = "unknown", keepSpacing = TRUE,
         drop = character(), keep = character())
{
    if(inherits(ifile, "srcfile"))
        ifile <- ifile$filename
    if (inherits(ifile, "Rd")) {
	# Undo sorting done in prepare2_Rd
	srcrefs <- sapply(ifile, function(s) attr(s, "srcref"))
	p <- ifile[ order(srcrefs[1,], srcrefs[2,]) ]
	class(p) <- class(ifile)
    } else
    	p <- parse_Rd(ifile, encoding = encoding)

    tags <- RdTags(p)

    if ("\\encoding" %in% tags) {
	encoding <- p[[which.max(tags == "\\encoding")]][[1L]]
	if (encoding %in% c("UTF-8", "utf-8", "utf8")) encoding <- "UTF-8"
	if (!inherits(ifile, "Rd"))
	    p <- parse_Rd(ifile, encoding=encoding)
    } else
	encoding <- ""

    ## Directly using a text connection to accumulate the filtered
    ## output seems to be faster than using .eval_with_capture(): to use
    ## the latter, change mycat to cat, or use mycat <- cat, and create
    ## out via
    ## out <- .eval_with_capture({
    ##     show(p)
    ##     mycat("\n")
    ## })$output

    myval <- character()
    mycon <- textConnection("myval", open = "w", local = TRUE,
                            encoding = "UTF-8")
    on.exit(close(mycon))
    mycat <- function(...) cat(..., file = mycon)

    prevline <- 1L
    prevcol <- 0L

    doPartialMarkup <- function(x, tags, i) { # handle things like \bold{pre}fix
        result <- FALSE
    	if (i < length(tags)
            && tags[i+1L] == "TEXT"
            && length(x[[i]]) == 1L
            && tags[i] %in% c("\\bold", "\\emph", "\\strong", "\\link")
            && !(tags[i] %in% drop)
            && RdTags(x[[i]]) == "TEXT") {
    	    text1 <- x[[i]][[1L]]
    	    if (length(grep("[^[:space:]]$", text1))) { # Ends in non-blank
    	    	text2 <- x[[i+1L]]
    	    	if (length(grep("^[^[:space:]]", text2))) { # Starts non-blank
    	    	    show(text1)
    	    	    prevcol <<- prevcol+1L # Shift text2 left by one column
    	    	    saveline <- prevline
    	    	    show(text2)
    	    	    if (prevline == saveline)
    	    	    	prevcol <<- prevcol-1L
    		    result <- TRUE
    		}
    	    }
	}
	result
    }

    show <- function(x) {
	srcref <- attr(x, "srcref")
	firstline <- srcref[1L]
	firstbyte <- srcref[2L]
	lastline <- srcref[3L]
	lastbyte <- srcref[4L]
	firstcol <- srcref[5L]
	lastcol <- srcref[6L]
	tag <- attr(x, "Rd_tag")
	if (is.null(tag)) tag <- "NULL"
	if (tag %in% drop) tag <- "DROP"
	else if (tag %in% keep) tag <- "KEEPLIST"  # Include both text and lists
	switch(tag,
	KEEP =,
	TEXT = {
	    if (prevline < firstline) {
		prevcol <<- 0L
		mycat(rep.int("\n",
                              if(keepSpacing) firstline - prevline else 1L))
	    }
	    if (keepSpacing)
                mycat(rep.int(" ", firstcol - prevcol - 1L), sep = "")
	    x <- as.character(srcref) # go back to original form
	    mycat(x, sep = "")
	    prevcol <<- lastcol
	    prevline <<- lastline
	},
	"\\S3method"=,
	"\\S4method"=,
        "\\command"=,
	"\\docType"=,
	"\\email"=,
	"\\encoding"=,
	"\\file"=,
	"\\keyword"=,
	"\\link"=,
        "\\linkS4class"=,
	"\\method"=,
	"\\pkg"=,
	"\\var"=,
	DROP = {},  # do nothing

	"\\tabular"=,
	"#ifdef"=,
	"#ifndef"={  # Ignore the first arg, process the second
	    show(x[[2L]])
	},
	"\\item"={   # Ignore the first arg of a two-arg item
	    if (length(x) == 2L) show(x[[2L]])
	},
	{	# default
	    if (is.list(x)) {
             	tags <- RdTags(x)
             	i <- 0L
             	while (i < length(x)) {
             	    i <- i + 1L
             	    if (doPartialMarkup(x, tags, i))
             	    	i <- i + 1L
             	    else
             		show(x[[i]])
             	}
	    } else if (tag == "KEEPLIST") {
	    	attr(x, "Rd_tag") <- "KEEP"
	    	show(x)
	    }
	})
    }

    show(p)
    mycat("\n")

    out <- textConnectionValue(mycon)

    ## Ideally, we would always canonicalize to UTF-8.
    ## However, when using RdTextFilter() for aspell(), it is not clear
    ## whether this is a good idea: the aspell program does not need to
    ## have full UTF-8 support (and what precisely holds is not clear:
    ## the manuals says that aspell
    ##   can easily check documents in UTF-8 without having to use a
    ##   special dictionary.
    ## but also
    ##   If Aspell is compiled with a version of the curses library that
    ##   support wide characters then Aspell can also check UTF-8 text.
    ## So at least until this can be resolved, turn filter results for
    ## Rd files originally in latin1 back to latin1.
    if(encoding == "latin1")
        out <- iconv(out, "UTF-8", "latin1")

    out
}
#  File src/library/tools/R/Rprof.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/

.Rprof <- function(args = NULL)
{
    do_exit <- function(status = 1L) q("no", status = status, runLast = FALSE)

    Usage <- function() {
        cat("Usage: R CMD Rprof [options] [file]",
            "",
            "Post-process profiling information in file generated by Rprof().",
            "",
            "Options:",
            "  -h, --help       print short help message and exit",
            "  -v, --version    print version info and exit",
            "  --lines          print line information",
            "  --total          print only by total",
            "  --self           print only by self",
            "  --linesonly      print only by line (implies --lines)",
            "  --min%total=     minimum % to print for 'by total'",
            "  --min%self=      minimum % to print for 'by self'",
            "",
            "If 'file' is omitted 'Rprof.out' is used",
            "",
            "Report bugs at bugs.r-project.org .", sep = "\n")
    }

    if (is.null(args)) {
        args <- commandArgs(TRUE)
        ## it seems that splits on spaces, so try harder.
        args <- paste(args, collapse=" ")
        args <- strsplit(args,'nextArg', fixed = TRUE)[[1L]][-1L]
    }

    files <- character()
    bytotal <- byself <- bylines <- TRUE
    lines <- FALSE
    mintotal <- minself <- -1L
    while(length(args)) {
        a <- args[1L]
        if (a %in% c("-h", "--help")) {
            Usage()
            do_exit(0L)
        }
        else if (a %in% c("-v", "--version")) {
            cat("R profiling post-processor: ",
                R.version[["major"]], ".",  R.version[["minor"]],
                " (r", R.version[["svn rev"]], ")\n", sep = "")
            cat("",
                "Copyright (C) 1997-2013 The R Core Team.",
                "This is free software; see the GNU General Public License version 2",
                "or later for copying conditions.  There is NO warranty.",
                sep = "\n")
            do_exit(0L)
        } else if (a == "--total") {
            bytotal <- TRUE
            byself <- FALSE
            bylines <- FALSE
        } else if (a == "--self") {
            bytotal <- FALSE
            byself <- TRUE
            bylines <- FALSE
        } else if (a == "--linesonly") {
            lines <- TRUE
            byself <- FALSE
            bytotal <- FALSE
            bylines <- TRUE
        } else if (a == "--lines") {
            lines <- TRUE
        } else if (substr(a, 1, 12)  == "--min%total=") {
            mintotal <- as.integer(substr(a, 13, 1000))
        } else if (substr(a, 1, 11)  == "--min%self=") {
            minself <- as.integer(substr(a, 12, 1000))
        } else files <- c(files, a)
        args <- args[-1L]
    }
    file <- if (!length(files)) "Rprof.out" else files[1L]

    res <- utils::summaryRprof(file, lines = if (lines) "show" else "hide")

    cat("\nEach sample represents", format(res$sample.interval), "seconds.\n")
    cat("Total run time:", format(res$sampling.time), "seconds.\n")
    cat("\nTotal seconds: time spent in function and callees.\n")
    cat("Self seconds: time spent in function alone.\n\n")

    printed <- FALSE
    if (bytotal) {
        m <- data.frame(res$by.total[c(2,1,4,3)], row.names(res$by.total))
        if(mintotal > 0) m <- m[m[,1L] >= mintotal,,drop = FALSE]
        writeLines(c("   %       total       %        self",
                     " total    seconds     self    seconds    name",
                     sprintf("%6.1f%10.2f%10.1f%10.2f     %s",
                             m[,1L], m[,2L], m[,3L], m[,4L], m[,5L])))
        printed <- TRUE
    }
    if(byself) {
        if (printed) cat("\n\n")
        m <- data.frame(res$by.self[c(2,1,4,3)], row.names(res$by.self))
        if(minself > 0) m <- m[m[,1L] >= minself,,drop = FALSE]
        writeLines(c("   %        self       %      total",
                     "  self    seconds    total   seconds    name",
                     sprintf("%6.1f%10.2f%10.1f%10.2f     %s",
                             m[,1L], m[,2L], m[,3L], m[,4L], m[,5L])))
        printed <- TRUE
    }
    if(lines && bylines) {
        if (printed) cat("\n\n")
        m <- data.frame(res$by.line[c(2,1,4,3)], row.names(res$by.line))
        if(minself > 0) m <- m[m[,1L] >= minself,,drop = FALSE]
        if(mintotal > 0) m <- m[m[,1L] >= mintotal,,drop = FALSE]
        writeLines(c("   %        self       %      total",
                     "  self    seconds    total   seconds    name",
                     sprintf("%6.1f%10.2f%10.1f%10.2f     %s",
                             m[,1L], m[,2L], m[,3L], m[,4L], m[,5L])))
    }
    do_exit(0L)
}
#  File src/library/tools/R/Sweavetools.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/


SweaveTeXFilter <-
function(ifile, encoding = "unknown")
{
    if(inherits(ifile, "srcfile"))
        ifile <- ifile$filename

    lines <- readLines(ifile, encoding = encoding, warn = FALSE)

    syntax <- utils:::SweaveGetSyntax(ifile)

    TEXT <- 1L
    CODE <- 0L

    recs <- rbind( data.frame(line = grep(syntax$doc, lines),
                              type = TEXT),
                   data.frame(line = grep(syntax$code, lines),
                              type = CODE))
    recs <- recs[order(recs$line),]
    last <- 0L
    state <- TEXT
    for (i in seq_len(nrow(recs))) {
    	line <- recs$line[i]
    	if (state == CODE)
    	    lines[(last+1L):line] <- ""
    	else
    	    lines[line] <- ""
    	state <- recs$type[i]
    	last <- line
    }
    lines
}
#  File src/library/tools/R/Vignettes.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/

vignette_is_tex <- function(file, ...) {
    (regexpr("[.]tex$", file, ignore.case = TRUE) != -1L)
}

# Infers the vignette type (PDF or HTML) from the filename of the
# final vignette product.
vignette_type <- function(file) {
    ext <- tolower(file_ext(file))
    type <- c(pdf="PDF", html="HTML")[ext]
    if (is.na(type))
        stop(gettextf("Vignette product %s does not have a known filename extension (%s)",
                      sQuote(file), paste(sQuote(names(type)), collapse=", ")),
             domain = NA)
    unname(type)
}

# Locates the vignette weave, tangle and texi2pdf product(s) based on the
# vignette name.   All such products must have the name as their filename
# prefix (i.e. "^<name>").
# For weave, final = TRUE will look for <name>.pdf and <name>.pdf, whereas
# with final = FALSE it also looks for <name>.tex (if <name>.pdf is also
# found, it will be returned).  For tangle, main = TRUE will look <name>.R,
# whereas main = FALSE will look for <name><anything>*.R.
# For texipdf, <name>.pdf is located.
find_vignette_product <-
    function(name, by = c("weave", "tangle", "texi2pdf"),
             final = FALSE, main = TRUE, dir = ".", engine, ...)
{
    stopifnot(length(name) == 1L)
    by <- match.arg(by)
    stopifnot(file_test("-d", dir))

    if (by == "weave") {
        if (final)
            exts <- c("pdf", "html")
        else
            exts <- c("pdf", "html", "tex")
    } else if (by == "tangle") {
        exts <- c("r", "s")
    } else if (by == "texi2pdf") {
        exts <- "pdf"
    }
    exts <- c(exts, toupper(exts))
    pattern1 <- sprintf("^%s[.](%s)$", name, paste(exts, collapse = "|"))
    output0 <- list.files(path = dir, all.files = FALSE, full.names = FALSE, no..=TRUE)
    output0 <- output0[file_test("-f", file.path(dir, output0))]
    output <- grep(pattern1, output0, value = TRUE)
    # If main is FALSE, we want to find all other files with related names.  We make sure
    # that the main file is in position 1.
    # FIXME:  we should check a timestamp or something to see that these were produced by tangling
    #	      for the "name" vignette, they aren't just coincidentally similar names.
    if (!main) {
	pattern2 <- sprintf("^%s.*[.](%s)$", name, paste(exts, collapse = "|"))
	output2 <- grep(pattern2, output0, value = TRUE)
	output <- c(output, setdiff(output2, output))
    }

    if (by == "weave") {
        if (length(output) == 0L)
            stop(gettextf("Failed to locate the %s output file (by engine %s) for vignette with name %s. The following files exist in directory %s: %s",
                          sQuote(by),
                          sQuote(sprintf("%s::%s", engine$package, engine$name)),
                          sQuote(name), sQuote(dir),
                          paste(sQuote(output0), collapse=", ")),
                 domain = NA)
        if (length(output) > 2L || (final && length(output) > 1L))
            stop(gettextf("Located more than one %s output file (by engine %s) for vignette with name %s: %s", sQuote(by),
                          sQuote(sprintf("%s::%s", engine$package, engine$name)),
                          sQuote(name), paste(sQuote(output), collapse=", ")),
                 domain  = NA)
	# If weave produced a TeX and then a PDF without cleaning out
	# the TeX, consider the newer one (PDF wins a tie) as the weave product
	if (length(output) == 2L) {
	    idxs <- match(tolower(file_ext(output)), exts)
	    output <- output[order(idxs)]
	    if (file_test("-nt", output[2L], output[1L])) output <- output[2L]
	    else output <- output[1L]
        }
    } else if (by == "tangle") {
        if (main)
            stopifnot(length(output) <= 1L)
    } else if (by == "texi2pdf") {
        if (length(output) == 0L)
            stop(gettextf("Failed to locate the %s output file (by engine %s) for vignette with name %s. The following files exist in directory %s: %s",
                          sQuote(by),
                          sQuote(sprintf("%s::%s", engine$package, engine$name)),
                          sQuote(name), sQuote(dir),
                          paste(sQuote(output0), collapse=", ")),
                 domain = NA)
        if (length(output) > 1L)
            stop(gettextf("Located more than one %s output file (by engine %s) for vignette with name %s: %s",
                          sQuote(by),
                          sQuote(sprintf("%s::%s", engine$package, engine$name)),
                          sQuote(name), paste(sQuote(output), collapse=", ")),
                 domain = NA)
    }

    if (length(output) > 0L) {
        if (dir == ".")
            output <- basename(output)
        else
            output <- file.path(dir, output)
    } else {
        output <- NULL
    }

    output
}



### * checkVignettes
###
### Run a tangle+source and a weave on all vignettes of a package.

checkVignettes <-
function(package, dir, lib.loc = NULL,
         tangle = TRUE, weave = TRUE, latex = FALSE,
         workdir = c("tmp", "src", "cur"),
         keepfiles = FALSE)
{
    vigns <- pkgVignettes(package = package, dir = dir, lib.loc = lib.loc)
    if(is.null(vigns)) return(NULL)

    workdir <- match.arg(workdir)
    wd <- getwd()
    if (is.null(wd))
        stop("current working directory cannot be ascertained")
    if(workdir == "tmp") {
        tmpd <- tempfile("Sweave")   ## <= Rename?
        if(!dir.create(tmpd))
            stop(gettextf("unable to create temp directory %s ", sQuote(tmpd)),
                 domain = NA)
        setwd(tmpd)
    }
    else {
        keepfiles <- TRUE
        if(workdir == "src") setwd(vigns$dir)
    }

    on.exit({
        setwd(wd)
        if(!keepfiles) unlink(tmpd, recursive = TRUE)
    })

    file.create(".check.timestamp")
    result <- list(tangle = list(), weave = list(),
                   source = list(), latex = list())

    loadVignetteBuilder(vigns$pkgdir)

    startdir <- getwd()
    for(i in seq_along(vigns$docs)) {
        file <- vigns$docs[i]
        file <- basename(file)
        name <- vigns$names[i]
    	engine <- vignetteEngine(vigns$engines[i])

        if(tangle) {
            message("  Running ", sQuote(file))
            .eval_with_capture({
                result$tangle[[file]] <- tryCatch({
                    engine$tangle(file, quiet = TRUE)
                    setwd(startdir) # in case a vignette changes the working dir
                    find_vignette_product(name, by = "tangle", main = FALSE, engine = engine)
                }, error = function(e) e)
            })
        }
        if(weave) {
            setwd(startdir) # in case a vignette changes the working dir then errored out
            .eval_with_capture({
                result$weave[[file]] <- tryCatch({
                    engine$weave(file, quiet = TRUE)
                    setwd(startdir)
                    find_vignette_product(name, by = "weave", engine = engine)
                }, error = function(e) e)
            })
        }
        setwd(startdir) # in case a vignette changes the working dir then errored out
    }

    # Assert that output files were not overwritten
    for (name in c("weave", "tangle")) {
        resultsT <- result[[name]]
        if (length(resultsT) <= 1L)
            next

        for (i in 1L:(length(resultsT)-1L)) {
            outputsI <- resultsT[[i]]
            if (inherits(outputsI, "error"))
                next;
            outputsI <- normalizePath(outputsI)

            for (j in (i+1L):length(resultsT)) {
                 outputsJ <- resultsT[[j]]
                 if (inherits(outputsJ, "error"))
                     next;
                 outputsJ <- normalizePath(outputsJ)
                 bad <- intersect(outputsJ, outputsI)
                 if (length(bad) > 0L) {
                     stop(gettextf("Vignette %s overwrites the following %s output by vignette %s: %s",
                                   sQuote(basename(names(resultsT)[j])),
                                   sQuote(name),
                                   sQuote(basename(names(resultsT)[i])),
                                   paste(basename(bad), collapse=", ")),
                          domain = NA)
                 }
            }
        }
    }

    if(tangle) {
        ## Tangling can create several source files if splitting is on,
        ## and these can be .R or .S (at least).  However, there is
        ## no guarantee that running them in alphabetical order in a
        ## session will work -- with named chunks it normally will not.
        cwd <- getwd()
        if (is.null(cwd))
            stop("current working directory cannot be ascertained")
        for(i in seq_along(result$tangle)) {
            sources <- result$tangle[[i]]
            if (inherits(sources, "error"))
                next
            sources <- sources[file_test("-nt", sources, ".check.timestamp")]
            for(file in sources) {
                .eval_with_capture({
                    result$source[[file]] <- tryCatch({
                        source(file)
                    }, error = function(e) e)
                })
                setwd(startdir)
            }
        }
    }

    if(weave && latex) {
        if(!("Makefile" %in% list.files(vigns$dir))) {
            ## <NOTE>
            ## This used to run texi2dvi on *all* vignettes, including
            ## the ones already known from the above to give trouble.
            ## In addition, texi2dvi errors were not caught, so that in
            ## particular the results of the previous QC analysis were
            ## *not* returned in case of such errors ...
            ## Hence, let us
            ## * Only run texi2dvi() on previously unproblematic vignettes
            ## * Catch texi2dvi() errors similar to the above.
            ## * Do *not* immediately show texi2dvi() output as part of
            ##   running checkVignettes().
            ## (For the future, maybe keep this output and provide it as
            ## additional diagnostics ...)
            ## </NOTE>
            for (i in seq_along(result$weave)) {
                file <- names(result$weave)[i]
                output <- result$weave[i]
                if (inherits(output, "error"))
                    next
                if (!vignette_is_tex(output))
                    next
                .eval_with_capture({
                    result$latex[[file]] <- tryCatch({
                       texi2pdf(file = output, clean = FALSE, quiet = TRUE)
                       find_vignette_product(name, by = "texi2pdf", engine = engine)
                    }, error = function(e) e)
                })
            }
        }
    }

    # Cleanup results
    for (name in c("tangle", "weave", "source", "latex")) {
        resultsT <- result[[name]]
        resultsT <- lapply(resultsT, FUN = function(res) {
          if (inherits(res, "error"))
              conditionMessage(res)
          else
              NULL
        })
        resultsT <- resultsT[!sapply(resultsT, FUN = is.null)]
        result[[name]] <- resultsT
    }

    file.remove(".check.timestamp")
    class(result) <- "checkVignettes"
    result
}

print.checkVignettes <-
function(x, ...)
{
    mycat <- function(y, title) {
        if(length(y)){
            cat("\n", title, "\n\n", sep = "")
            for(k in seq_along(y)) {
                cat("File", names(y)[k], ":\n")
                cat(as.character(y[[k]]), "\n")
            }
        }
    }

    mycat(x$tangle, "*** Tangle Errors ***")
    mycat(x$source, "*** Source Errors ***")
    mycat(x$weave,  "*** Weave Errors ***")
    mycat(x$latex,  "*** PDFLaTeX Errors ***")

    invisible(x)
}

### get the engine from a file

getVignetteEngine <- function(filename, lines = readLines(filename, warn=FALSE)) {
    c(.get_vignette_metadata(lines, "Engine"), "utils::Sweave")[1L]
}

### * engineMatches
###
### does the engine from a vignette match one of the registered ones?
###
engineMatches <- function(regengine, vigengine) {
    if (!grepl("::", vigengine))
	regengine <- sub("^.*::", "", regengine)
    regengine == vigengine
}

### * pkgVignettes
###
### Get an object of class pkgVignettes which contains a list of
### vignette source files, the registered vignette engine for
### each of them, and the name of the directory which contains them.

### A vector of 'subdirs' is allowed for historical reasons but the
### first which exists is used.

pkgVignettes <-
function(package, dir, subdirs = NULL, lib.loc = NULL, output = FALSE,
         source = FALSE, check = FALSE)
{
    ## Argument handling.
    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        dir <- find.package(package, lib.loc)
    }
    if(missing(dir))
	stop("you must specify 'package' or 'dir'")
    ## Using sources from directory @code{dir} ...
    if(!file_test("-d", dir))
	stop(gettextf("directory '%s' does not exist", dir), domain = NA)
    else {
	dir <- file_path_as_absolute(dir)
	if (is.null(subdirs))
	    subdirs <- if (missing(package)) "vignettes" else "doc"
	for (subdir in subdirs) {
	    docdir <- file.path(dir, subdir)
	    if(file_test("-d", docdir))
		break
	}
    }

    if(!file_test("-d", docdir)) return(NULL)

    # Locate all vignette files
    buildPkgs <- loadVignetteBuilder(dir, mustwork = FALSE)
    engineList <- vignetteEngine(package = buildPkgs)

    docs <- names <- engines <- patterns <- character()
    allFiles <- list.files(docdir, all.files = FALSE, full.names = TRUE)
    matchedPattern <- rep(FALSE, length(allFiles))
    msg <- character()
    if (length(allFiles) > 0L) {
        for (name in names(engineList)) {
            engine <- engineList[[name]]
            patternsT <- engine$pattern
            for (pattern in patternsT) {
                idxs <- grep(pattern, allFiles)
		docsT <- allFiles[idxs]
		matchedPattern[idxs] <- TRUE
		keep <- logical(length(docsT))
		for (i in seq_along(docsT))
		    keep[i] <- engineMatches(name, getVignetteEngine(docsT[i]))
		idxs  <- idxs[keep]
                nidxs <- length(idxs)
                if (nidxs > 0L) {
                    if (is.function(engine$weave)) {
                        docsT <- allFiles[idxs]
                        docs <- c(docs, docsT)
                        names <- c(names, gsub(pattern, "", basename(docsT)))
                        engines <- c(engines, rep(name, times = nidxs))
                        patterns <- c(patterns, rep(pattern, times = nidxs))
                    }
		    matchedPattern <- matchedPattern[-idxs]
                    allFiles <- allFiles[-idxs]
                    if (length(allFiles) == 0L)
                        break
                }
            }
        }
	if (check && any(matchedPattern)) {
            files <- substring(allFiles[matchedPattern], nchar(dir) + 2)
            msg <- c("Files named as vignettes but with no recognized vignette engine:",
                     paste("  ", sQuote(files)),
                     "(Is a VignetteBuilder field missing?)")
        }
    }

    # Assert
    stopifnot(length(names) == length(docs))
    stopifnot(length(engines) == length(docs))
    stopifnot(length(patterns) == length(docs))
    stopifnot(!any(duplicated(docs)))

    z <- list(docs=docs, names=names, engines=engines, patterns=patterns,
              dir=docdir, pkgdir=dir, msg = msg)

    if (output) {
        outputs <- character(length(docs))
        for (i in seq_along(docs)) {
            file <- docs[i]
            name <- names[i]
            outputI <- find_vignette_product(name, by = "weave", dir = docdir, engine = engine)
            outputs[i] <- outputI
        }
        z$outputs <- outputs
    }

    if (source) {
        sources <- list()
        for (i in seq_along(docs)) {
            file <- docs[i]
            name <- names[i]
            sourcesI <- find_vignette_product(name, by = "tangle", main = FALSE, dir = docdir, engine = engine)
            sources[[file]] <- sourcesI
        }
        z$sources <- sources
    }

    class(z) <- "pkgVignettes"
    z
}


### * buildVignettes
###
### Run a weave and pdflatex on all vignettes of a package and try to
### remove all temporary files that were created.

buildVignettes <-
function(package, dir, lib.loc = NULL, quiet = TRUE, clean = TRUE, tangle = FALSE)
{
    vigns <- pkgVignettes(package = package, dir = dir, lib.loc = lib.loc, check = TRUE)
    if(is.null(vigns)) return(invisible())
    if(length(vigns$msg))
        warning(paste(vigns$msg, collapse = "\n"), domain = NA)

    ## Assert that duplicated vignette names do not exist, e.g.
    ## 'vig' and 'vig' from 'vig.Rnw' and 'vig.Snw'.
    dups <- duplicated(vigns$names)
    if (any(dups)) {
        names <- unique(vigns$names[dups])
        docs <- sort(basename(vigns$docs[vigns$names %in% names]))
        stop(gettextf("Detected vignette source files (%s) with shared names (%s) and therefore risking overwriting each others output files",
                      paste(sQuote(docs), collapse=", "),
                      paste(sQuote(names), collapse=", ")),
             domain = NA)
    }

    ## unset SWEAVE_STYLEPATH_DEFAULT here to avoid problems
    Sys.unsetenv("SWEAVE_STYLEPATH_DEFAULT")

    op <- options(warn = 1) # we run vignettes in this process
    wd <- getwd()
    if (is.null(wd))
        stop("current working directory cannot be ascertained")
    on.exit({
        setwd(wd)
        options(op)
    })

    setwd(vigns$dir)

    ## FIXME: should this recurse into subdirs?
    origfiles <- list.files(all.files = TRUE)

    ## Note, as from 2.13.0, only this case
    have.makefile <- "Makefile" %in% origfiles
    WINDOWS <- .Platform$OS.type == "windows"

    file.create(".build.timestamp")

    loadVignetteBuilder(vigns$pkgdir)
    outputs <- NULL
    sourceList <- list()
    startdir <- getwd()
    for(i in seq_along(vigns$docs)) {
        file <- vigns$docs[i]
        file <- basename(file)
        name <- vigns$names[i]
    	engine <- vignetteEngine(vigns$engine[i])

        output <- tryCatch({
            engine$weave(file, quiet = quiet)
            setwd(startdir)
            find_vignette_product(name, by = "weave", engine = engine)
        }, error = function(e) {
            stop(gettextf("processing vignette '%s' failed with diagnostics:\n%s",
                 file, conditionMessage(e)), domain = NA, call. = FALSE)
        })

        ## This can fail if run in a directory whose path contains spaces.
        if(!have.makefile && vignette_is_tex(output)) {
            texi2pdf(file = output, clean = FALSE, quiet = quiet)
            output <- find_vignette_product(name, by = "texi2pdf", engine = engine)
        }
        outputs <- c(outputs, output)

        if (tangle) {  # This is set for all engines as of 3.0.2
            output <- tryCatch({
                engine$tangle(file, quiet = quiet)
                setwd(startdir)
                find_vignette_product(name, by = "tangle", main = FALSE, engine = engine)
            }, error = function(e) {
                stop(gettextf("tangling vignette '%s' failed with diagnostics:\n%s",
                     file, conditionMessage(e)), domain = NA, call. = FALSE)
            })
            sourceList[[file]] <- output
        }
    }

    if(have.makefile) {
        if (WINDOWS) {
            ## Some people have *assumed* that R_HOME uses / in Makefiles
            ## Spaces in paths might still cause trouble.
            rhome <- chartr("\\", "/", R.home())
            Sys.setenv(R_HOME = rhome)
        }
    	make <- Sys.getenv("MAKE", "make")
        if(!nzchar(make)) make <- "make"
        yy <- system(make)
        if(yy > 0) stop("running 'make' failed")
        ## See if Makefile has a clean: target, and if so run it.
        if(clean &&
           any(grepl("^clean:", readLines("Makefile", warn = FALSE))))
            system(paste(make, "clean"))
    } else {
        ## Badly-written vignettes open a pdf() device on Rplots.pdf and
        ## fail to close it.
        graphics.off()

        keep <- c(outputs, unlist(sourceList))
        if(clean) {
            f <- setdiff(list.files(all.files = TRUE, no.. = TRUE), keep)
            newer <- file_test("-nt", f, ".build.timestamp")
            ## some packages, e.g. SOAR, create directories
            unlink(f[newer], recursive = TRUE)
        }
        f <- setdiff(list.files(all.files = TRUE, no.. = TRUE),
                     c(keep, origfiles))
        f <- f[file_test("-f", f)]
        file.remove(f)
    }

    # Assert
    stopifnot(length(outputs) == length(vigns$docs))

    vigns$outputs <- outputs
    vigns$sources <- sourceList

    if(file.exists(".build.timestamp")) file.remove(".build.timestamp")
    ## Might have been in origfiles ...

    invisible(vigns)
}

### * buildVignette
###
### Run a weave and/or tangle on one vignette and try to
### remove all temporary files that were created.

buildVignette <-
    function(file, dir = ".", weave = TRUE, latex = TRUE, tangle = TRUE,
    quiet = TRUE, clean = TRUE, engine = NULL, buildPkg = NULL, ...)
{

    if (!file_test("-f", file))
	stop(gettextf("file '%s' not found", file), domain = NA)

    if (!file_test("-d", dir))
	stop(gettextf("directory '%s' does not exist", dir), domain = NA)

    if (!is.null(buildPkg))
	for (pkg in buildPkg)
	    loadNamespace(pkg)

    if (is.null(engine))
    # Infer vignette engine from vignette content
	engine <- getVignetteEngine(file)

    # Get the vignette engine
    if (is.character(engine))
	engine <- vignetteEngine(engine, package = buildPkg)

    # Infer the vignette name
    names <- sapply(engine$pattern, FUN = sub, "", file)
    name <- basename(names[(names != file)][1L])

    # A non-matching filename?
    if (is.na(name))
	stop(gettextf("vignette filename '%s' does not match any of the '%s' filename patterns",
		file, paste(engine$package, engine$name, sep="::")),
		domain = NA)

    # Set output directory temporarily
    file <- file_path_as_absolute(file)
    olddir <- getwd()
    if (!is.null(olddir)) on.exit(setwd(olddir))
    setwd(dir)

    # Record existing files
    origfiles <- list.files(all.files = TRUE)
    if (is.na(clean) || clean) {
	file.create(".build.timestamp")
    }

    tdir <- getwd()# if 'dir' was relative, resetting to tdir will work
    output <- NULL

    # Weave
    final <- if (weave) {
	engine$weave(file, quiet = quiet, ...)
	setwd(tdir)  # In case weave/vignette changed it
	output <- find_vignette_product(name, by = "weave", engine = engine)

	# Compile TeX to PDF?
	if(latex && vignette_is_tex(output)) {
	    texi2pdf(file = output, clean = FALSE, quiet = quiet)
	    find_vignette_product(name, by = "texi2pdf", engine = engine)
	} else
	    output
    } # else NULL

    # Tangle
    sources <- if (tangle) {
	engine$tangle(file, quiet = quiet, ...)
	setwd(tdir)  # In case tangle changed it
	find_vignette_product(name, by = "tangle", main = FALSE, engine = engine)
    } # else NULL

    # Cleanup
    keep <- c(sources, final)
    if (is.na(clean)) {  # Use NA to signal we want .tex files kept.
	keep <- c(keep, output)
	clean <- TRUE
    }
    if (clean) {
	f <- setdiff(list.files(all.files = TRUE, no.. = TRUE), keep)
	newer <- file_test("-nt", f, ".build.timestamp")
	## some packages create directories
	unlink(f[newer], recursive = TRUE)
    }
    f <- setdiff(list.files(all.files = TRUE, no.. = TRUE), c(keep, origfiles))
    f <- f[file_test("-f", f)]
    file.remove(f)

    unique(keep)
}

### * .getVignetteEncoding

getVignetteEncoding <-  function(file, ...)
{
    # Look for inputen[cx] first, then %\SweaveUTF8.  Complain about 
    # inconsistencies.
    
    lines <- readLines(file, warn = FALSE)
    result1 <- .getVignetteEncoding(lines, ...)
    
    poss <- grep("^[[:space:]]*%+[[:space:]]*\\\\SweaveUTF8[[:space:]]*$", lines, useBytes = TRUE)
    if (length(poss)) {
    	result <- "UTF-8"
    	if (!(result1 %in% c("", "non-ASCII", "UTF-8")))
    	    stop("Inconsistent encoding specifications: ", result1, " with %\\SweaveUTF8")
    } else 
    	result <- result1
    result
}

.getVignetteEncoding <- function(lines, convert = FALSE)
{
    ## Look for input enc lines using inputenc or inputenx
    ## Note, multiple encodings are excluded.

    poss <-
        grep("^[[:space:]]*\\\\usepackage\\[([[:alnum:]]+)\\]\\{inputen[cx]\\}",
             lines, useBytes = TRUE)
    ## Check it is in the preamble
    start <- grep("^[[:space:]]*\\\\begin\\{document\\}",
                  lines, useBytes = TRUE)
    if(length(start)) poss <- poss[poss < start[1L]]
    if(!length(poss)) {
        asc <- iconv(lines, "latin1", "ASCII")
        ind <- is.na(asc) | asc != lines
        if(any(ind)) return("non-ASCII")
        return("") # or "ASCII"
    }
    poss <- lines[poss[1L]]
    res <- gsub("^[[:space:]]*\\\\usepackage\\[([[:alnum:]]+)\\].*", "\\1",
                poss) # This line should be ASCII.
    if (convert) {
        ## see Rd2latex.R.
        ## Currently utf8, utf8x, latin1, latin9 and ansinew are in use.
        switch(res,
               "utf8" =, "utf8x" = "UTF-8",
               "latin1" =, "iso-8859-1" = "latin1",
               "latin2" =, "iso-8859-2" = "latin2",
               "latin9" =, "iso-8859-15" = "latin-9", # only form known to GNU libiconv
               "latin10" =, "iso-8859-16" = "latin10",
               "cyrillic" =, "iso-8859-5" =  "ISO-8859-5", # inputenx
               "koi8-r" =  "KOI8-R", # inputenx
               "arabic" = "ISO-8859-6", # Not clear next 3 are known to latex
               "greek" =, "iso-8859-7" = "ISO-8859-7",
               "hebrew" =, "iso-8859-8" = "ISO-8859-8",
               "ansinew" = "CP1252",
               "applemac" = "macroman",
               ## assume these only get used on Windows
               "cp1250" = "CP1250",
               "cp1252" = "CP1252",
               "cp1257" = "CP1257",
               "unknown")
    } else res
}

### * .build_vignette_index

.get_vignette_metadata <-
function(lines, tag)
{
    meta_RE <- paste("[[:space:]]*%+[[:space:]]*\\\\Vignette", tag,
                     "\\{([^}]*)\\}", sep = "")
    meta <- grep(meta_RE, lines, value = TRUE, useBytes = TRUE)
    .strip_whitespace(gsub(meta_RE, "\\1", meta))
}

vignetteInfo <-
function(file)
{
    lines <- readLines(file, warn = FALSE)

    ## <FIXME>
    ## Can only proceed with lines which are valid in the current locale.
    ## Unfortunately, vignette encodings are a mess: package encodings
    ## might apply, but be overridden by \inputencoding commands.
    ## For now, assume that vignette metadata occur in all ASCII lines.
    ## (Could also iconv() using sub = "byte".)
    lines[is.na(nchar(lines, "c", TRUE))] <- ""
    ## </FIXME>

    ## \VignetteIndexEntry
    title <- c(.get_vignette_metadata(lines, "IndexEntry"), "")[1L]
    ## \VignetteDepends
    depends <- .get_vignette_metadata(lines, "Depends")
    if(length(depends))
        depends <- unlist(strsplit(depends[1L], ", *"))
    ## \VignetteKeyword and old-style \VignetteKeywords
    keywords <- .get_vignette_metadata(lines, "Keywords")
    keywords <- if(!length(keywords)) {
        ## No old-style \VignetteKeywords entries found.
        .get_vignette_metadata(lines, "Keyword")
    } else unlist(strsplit(keywords[1L], ", *"))
    ## no point in recording the file path since this is called on
    ## package installation.
    engine <- getVignetteEngine(lines=lines)
    list(file = basename(file), title = title, depends = depends,
         keywords = keywords, engine = engine)
}

## The below builds vignette indices via 'pkgVignettes' objects.
.build_vignette_index <-
function(vigns)
{
    stopifnot(inherits(vigns, "pkgVignettes"))

    files <- vigns$docs
    names <- vigns$names
    dir <- vigns$dir
    sources <- vigns$sources

    if(!file_test("-d", dir))
        stop(gettextf("directory '%s' does not exist", dir), domain = NA)

    nvigns <- length(files)
    if(nvigns == 0L) {
        out <- data.frame(File = character(),
                          Title = character(),
                          PDF = character(),
			  R = character(),
                          stringsAsFactors = FALSE)
        out$Depends <- list()
        out$Keywords <- list()
        return(out)
    }

    # Check for duplicated vignette names
    if (any(dups <- duplicated(names))) {
    	dupname <- names[dups][1L]
    	dup <- basename(files[dups][1L])
    	orig <- basename(files[ names == dupname ][1L])
    	stop(gettextf("In '%s' vignettes '%s' and '%s' have the same vignette name",
    		      basename(dirname(dir)), orig, dup),
             domain = NA)
    }

    # Read vignette annotation from vignette source files
    contents <- vector("list", length = nvigns * 5L)
    dim(contents) <- c(nvigns, 5L)
    for(i in seq_along(files))
        contents[i, ] <- vignetteInfo(files[i])
    colnames(contents) <- c("File", "Title", "Depends", "Keywords", "Engine")

    ## This is to cover a temporary package installation
    ## by 'R CMD build' (via 'R CMD INSTALL -l <lib>)
    ## which in case vignettes have not been built.
    outputs <- vigns$outputs
    if (!is.null(outputs)) {
        outputs <- basename(outputs)
    } else {
        outputs <- character(nvigns)
    }

    out <- data.frame(File = unlist(contents[, "File"]),
                      Title = unlist(contents[, "Title"]),
                      PDF = outputs,	# Not necessarily PDF, but name it that for back compatibility
		      R = "",		# May or may not be present
                      row.names = NULL, # avoid trying to compute row
                                        # names
                      stringsAsFactors = FALSE)
    # Optional
    for (i in seq_along(sources))
	if (length(s <- sources[[i]]))
	    out$R[which(names(sources)[i] == files)] <- basename(s[1L])
    out$Depends <- contents[, "Depends"]
    out$Keywords <- contents[, "Keywords"]

    stopifnot(NROW(out) == nvigns)

    out
}

### * .check_vignette_index

.check_vignette_index <-
function(vignetteDir, pkgdir = ".")
{
    dir <- file.path(pkgdir, vignetteDir)
    if(!file_test("-d", dir))
        stop(gettextf("directory '%s' does not exist", dir), domain = NA)

    subdir <- gsub(pkgdir, "", dir, fixed=TRUE)
    vigns <- pkgVignettes(dir = pkgdir, subdirs = subdir)

    vignetteIndex <- .build_vignette_index(vigns)
    badEntries <-
        vignetteIndex[grep("^[[:space:]]*$", vignetteIndex[, "Title"]), "File"]
    class(badEntries) <- "check_vignette_index"
    badEntries
}

print.check_vignette_index <-
function(x, ...)
{
    if(length(x)) {
        writeLines(paste("Vignettes with missing or empty",
                         "\\VignetteIndexEntry:"))
        print(basename(unclass(x)), ...)
    }
    invisible(x)
}


### * .writeVignetteHtmlIndex

## NB SamplerCompare has a .Rnw file which produces no R code.
.writeVignetteHtmlIndex <-
function(pkg, con, vignetteIndex = NULL)
{
    ## FIXME: in principle we could need to set an encoding here
    html <- c(HTMLheader("Vignettes and other documentation"),
              paste0("<h2>Vignettes from package '", pkg,"'</h2>"))

    if(NROW(vignetteIndex) == 0L) { ## NROW(NULL) = 0
        html <-
            c(html,
              "The package contains no vignette meta-information.")
    } else {
    	vignetteIndex <- cbind(Package = pkg, as.matrix(vignetteIndex[,
                               c("File", "Title", "PDF", "R")]))
        html <- c(html, makeVignetteTable(vignetteIndex, depth = 3L))
    }
    otherfiles <- list.files(system.file("doc", package = pkg))
    if(NROW(vignetteIndex))
        otherfiles <- setdiff(otherfiles,
                              c(vignetteIndex[, c("PDF", "File", "R")], "index.html"))
    if (length(otherfiles)) {
    	otherfiles <- ifelse(file.info(system.file(file.path("doc", otherfiles), package=pkg))$isdir,
			     paste0(otherfiles, "/"),
			     otherfiles)
	urls <- paste0('<a href="', otherfiles, '">', otherfiles, '</a>')
        html <- c(html, '<h2>Other files in the <span class="samp">doc</span> directory</h2>',
                  '<table width="100%">',
		  '<col width="24%">',
		  '<col width="50%">',
		  '<col width="24%">',
                  paste0('<tr><td></td><td><span class="samp">',
                         iconv(urls, "", "UTF-8"), "</span></td></tr>"),
                  "</dl>")
    }
    html <- c(html, "</body></html>")
    writeLines(html, con=con)
}

vignetteDepends <-
function(vignette, recursive = TRUE, reduce = TRUE,
         local = TRUE, lib.loc = NULL)
{
    if (length(vignette) != 1L)
        stop("argument 'vignette' must be of length 1")
    if (!nzchar(vignette)) return(invisible()) # lets examples work.
    if (!file.exists(vignette))
        stop(gettextf("file '%s' not found", vignette), domain = NA)

    vigDeps <- vignetteInfo(vignette)$depends

    depMtrx <- getVigDepMtrx(vigDeps)
    instPkgs <- utils::installed.packages(lib.loc=lib.loc)
    getDepList(depMtrx, instPkgs, recursive, local, reduce,
               lib.loc)
}

getVigDepMtrx <-
function(vigDeps)
{
    ## Taken almost directly out of 'package.dependencies'
    if (length(vigDeps)) {
        z <- unlist(strsplit(vigDeps, ",", fixed=TRUE))
        z <- sub("^[[:space:]]*(.*)", "\\1", z)
        z <- sub("(.*)[[:space:]]*$", "\\1", z)
        pat <- "^([^\\([:space:]]+)[[:space:]]*\\(([^\\)]+)\\).*"
        depMtrx <- cbind(sub(pat, "\\1", z),
                         sub(pat, "\\2", z),
                         NA)
        noversion <- depMtrx[, 1L] == depMtrx[, 2L]
        depMtrx[noversion, 2L] <- NA
        pat <- "[[:space:]]*([[<>=]+)[[:space:]]+(.*)"
        depMtrx[!noversion, 2:3] <-
            c(sub(pat, "\\1", depMtrx[!noversion, 2L]),
              sub(pat, "\\2", depMtrx[!noversion, 2L]))
        depMtrx
    }
    else
        NA
}

### * .run_one_vignette
### helper for R CMD check

.run_one_vignette <-
function(vig_name, docDir, encoding = "", pkgdir)
{
    ## The idea about encodings here is that Stangle reads the
    ## file, converts on read and outputs in the current encoding.
    ## Then source() can assume the current encoding.
    td <- tempfile()
    dir.create(td)
    file.copy(docDir, td, recursive = TRUE)
    setwd(file.path(td, basename(docDir)))

    subdir <- gsub(pkgdir, "", docDir, fixed=TRUE)
    vigns <- pkgVignettes(dir=pkgdir, subdirs=subdir)
    if (is.null(vigns)) {
       cat("\n  When running vignette ", sQuote(vig_name), ":\n", sep="")
       stop("No vignettes available", call. = FALSE, domain = NA)
    }

    i <- which(basename(vigns$docs) == vig_name)
    if (length(i) == 0L) {
       cat("\n  When running vignette ", sQuote(vig_name), ":\n", sep="")
       stop("No such vignette ", sQuote(vig_name), call. = FALSE, domain = NA)
    }
    stopifnot(length(i) == 1L)

    loadVignetteBuilder(pkgdir)
    file <- vigns$docs[i]
    file <- basename(file)
    name <- vigns$names[i]
    engine <- vignetteEngine(vigns$engine[i])

    output <- tryCatch({
        engine$tangle(file, quiet = TRUE, encoding = encoding)
        find_vignette_product(name, by = "tangle", engine = engine)
    }, error = function(e) {
        cat("\n  When tangling ", sQuote(file), ":\n", sep="")
        stop(conditionMessage(e), call. = FALSE, domain = NA)
    })

    if(length(output) == 1L) {
        res <- tryCatch({
            source(output, echo = TRUE)
        }, error = function(e) {
            cat("\n  When sourcing ", sQuote(output), ":\n", sep="")
            stop(conditionMessage(e), call. = FALSE, domain = NA)
        })
    }

    cat("\n *** Run successfully completed ***\n")
}

vignetteEngine <- local({
    registry <- new.env(parent = emptyenv())

    engineKey <- function(name, package) {
        key <- strsplit(name, split = "::", fixed = TRUE)[[1L]]
        if (length(key) == 1L) {
	    if (missing(package))
		stop("Vignette engine package not specified", call.=FALSE)
            key[2L] <- key[1L]
            key[1L] <- package
        } else if (length(key) != 2L) {
            stop("Unsupported engine name ", sQuote(name))
        }
        key
    }

    getEngine <- function(name, package) {
        if (missing(name)) {
            result <- as.list(registry)
            if (length(result) > 0L && !is.null(package)) {
               package <- unique(package)
               pkgs <- sapply(result, function(engine) engine$package)
               keep <- is.element(pkgs, package)
               if (!any(keep)) {
                   stop(gettextf("None of packages %s have registered vignette engines",
                                 paste(sQuote(package), collapse = ", ")),
                        domain = NA)
               }
               result <- result[keep]
               pkgs <- pkgs[keep]
               if (length(package) > 1L) {
                 result <- result[order(match(pkgs, package))]
               }
            }
        } else {
            result <- NULL
            if (is.null(package)) {
                if (name == "Sweave") {
                    key <- engineKey(name, package = "utils")
                } else {
                    key <- engineKey(name)
                }
		loadNamespace(key[1])
                name <- paste(key, collapse = "::")
                result <- registry[[name]]
                if (is.null(result))
                    stop(gettextf("Vignette engine %s is not registered",
                                  sQuote(name)), domain = NA)
            } else {
                for (pkg in package) {
                    key <- engineKey(name, pkg)
		    try(loadNamespace(key[1]), silent = TRUE)
                    nameT <- paste(key, collapse = "::")
                    result <- registry[[nameT]]
                    if (!is.null(result))
                        break
                }
                if (is.null(result))
                    stop(gettextf("Vignette engine %s is not registered by any of the packages %s",
                                  sQuote(name),
                                  paste(sQuote(package), collapse = ", ")),
                         domain = NA)
            }

            if (!is.null(package) && !is.element(result$package, package))
                stop(gettextf("Vignette engine %s is not registered by any of the packages %s",
                              sQuote(name),
                              paste(sQuote(package), collapse = ", ")),
                     domain = NA)
        }
        result
    }

    setEngine <- function(name, package, pattern, weave, tangle,
                          aspell = list()) {
        key <- engineKey(name, package)
        if (!is.null(package) && key[1L] != package)
            stop(gettextf("Engine name %s and package %s do not match",
                          sQuote(name), sQuote(package)), domain = NA)


        rname <- paste(key, collapse = "::")
        if (is.null(weave)) {
            result <- NULL
            if (exists(rname, envir = registry))
                rm(list = rname, envir = registry)
        } else {
            if (!is.function(weave) && is.na(weave)) {
                if (missing(tangle))
                    tangle <- NA
            } else {
                if (!is.function(weave))
                    stop(gettextf("Argument %s must be a function and not %s",
                                  sQuote("weave"), sQuote(class(weave)[1L])),
                         domain = NA)
                if (!is.function(tangle))
                    stop(gettextf("Argument %s must be a function and not %s",
                                  sQuote("tangle"), sQuote(class(tangle)[1L])),
                         domain = NA)
            }
            if (is.null(pattern))
                pattern <- "[.][rRsS](nw|tex)$"
            else if (!is.character(pattern))
                stop(gettextf("Argument %s must be a character vector or NULL and not %s",
                              sQuote("pattern"), sQuote(class(pattern)[1L])),
                     domain = NA)

            result <-
                list(name = key[2L], package = key[1L], pattern = pattern,
                     weave = weave, tangle = tangle, aspell = aspell)
            assign(rname, result, registry)
        }

        result
    }

    setEngine(name = "Sweave", package = "utils", pattern = NULL,
              weave = function(...) utils::Sweave(...),
              tangle = function(...) utils::Stangle(...),
              aspell = list(filter = "Sweave", control = "-t"))

    function(name, weave, tangle, pattern = NULL, package = NULL,
             aspell = list()) {
        if (missing(weave)) { # we're getting the engine
            getEngine(name, package)
        } else { # we're setting a new engine
            if (is.element(name, c("Sweave", "utils::Sweave"))) {
                stop(gettextf("Cannot change the %s engine or use an engine of that name",
                              sQuote("Sweave")), domain = NA)
            }
            if (missing(package))
                package <- utils::packageName(parent.frame())
            result <-
                setEngine(name, package, pattern = pattern,
                          weave = weave, tangle = tangle, aspell = aspell)
            invisible(result)
        }
    }
})

loadVignetteBuilder <-
function(pkgdir, mustwork = TRUE)
{
    pkgs <- .get_package_metadata(pkgdir)["VignetteBuilder"]
    if (is.na(pkgs))
        pkgs <- NULL
    else if (length(pkgs) > 0L) {
        pkgs <- unlist(strsplit(pkgs, ","))
        pkgs <- gsub('[[:space:]]', '', pkgs)
    }
    pkgs <- unique(c(pkgs, "utils"))

    for (pkg in pkgs) {
	res <- tryCatch(loadNamespace(pkg), error = function(e)e)
	if (mustwork && inherits(res, "error"))
            stop(gettextf("vignette builder '%s' not found", pkg), domain = NA)
    }
    pkgs
}

# This gets the info for installed packages

getVignetteInfo <- function(package = NULL, lib.loc = NULL, all = TRUE)
{
    if (is.null(package)) {
        package <- .packages(all.available = all, lib.loc)
        ## allow for misnamed dirs
        paths <- find.package(package, lib.loc, quiet = TRUE)
    } else paths <- find.package(package, lib.loc)

    ## Find the directories with a 'doc' subdirectory *possibly*
    ## containing vignettes.

    paths <- paths[file_test("-d", file.path(paths, "doc"))]

    empty <- cbind(Package = character(0),
                   Dir = character(0),
                   Topic = character(0),
                   File = character(0),
                   Title = character(0),
                   R = character(0),
                   PDF = character(0))

    getVinfo <- function(dir) {
        entries <- NULL
        if (file.exists(INDEX <- file.path(dir, "Meta", "vignette.rds")))
            entries <- readRDS(INDEX)
        if (NROW(entries) > 0) {
            # FIXME:  this test is unnecessary?
            if (is.null(entries$R)) R <- rep("", NROW(entries))
            else R <- entries$R
            file <- basename(entries$File)
            pdf <- entries$PDF
            topic <- file_path_sans_ext(ifelse(R == "", ifelse(pdf == "", file, pdf), R))
            cbind(Package = basename(dir),
                  Dir = dir,
                  Topic = topic,
                  File = file,
                  Title = entries$Title,
                  R = R,
                  PDF = pdf)[order(entries$Title), , drop=FALSE]
        }
        else empty
    }

    if (length(paths))
    	do.call(rbind, lapply(paths, getVinfo))
    else
    	empty
}

### Local variables: ***
### mode: outline-minor ***
### outline-regexp: "### [*]+" ***
### End: ***
#  File src/library/tools/R/admin.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/


### * .install_package_description

## called from basepkg.mk and .install_packages
.install_package_description <-
function(dir, outDir)
{
    ## Function for taking the DESCRIPTION package meta-information,
    ## checking/validating it, and installing it with the 'Built:'
    ## field added.  Note that from 1.7.0 on, packages without
    ## compiled code are not marked as being from any platform.

    ## Check first.  Note that this also calls .read_description(), but
    ## .check_package_description() currently really needs to know the
    ## path to the DESCRIPTION file, and returns an object with check
    ## results and not the package metadata ...
    ok <- .check_package_description(file.path(dir, "DESCRIPTION"))
    if(any(as.integer(sapply(ok, length)) > 0L)) {
        stop(paste(gettext("Invalid DESCRIPTION file") ,
                   paste(.eval_with_capture(print(ok))$output,
                         collapse = "\n"),
                   sep = "\n\n"),
             domain = NA,
             call. = FALSE)
    }

    ## This reads (in C locale) byte-by-byte, declares latin1 or UTF-8
    ## Maybe it would be better to re-encode others (there are none at
    ## present, at least in a UTF-8 locale?
    db <- .read_description(file.path(dir, "DESCRIPTION"))

    ## should not have a Built: field, so ignore it if it is there
    nm <- names(db)
    if("Built" %in% nm) {
        db <- db[-match("Built", nm)]
        warning(gettextf("*** someone has corrupted the Built field in package '%s' ***",
                         db["Package"]),
                domain = NA,
                call. = FALSE)
    }

    OStype <- R.version$platform
    if (length(grep("-apple-darwin", R.version$platform)) &&
        nzchar(Sys.getenv("R_ARCH")))
        OStype <- sub(".*-apple-darwin", "universal-apple-darwin", OStype)
    Built <-
	paste0("R ",
	       paste(R.version[c("major", "minor")], collapse = "."),
	       "; ",
	       if(file_test("-d", file.path(dir, "src"))) OStype else "",
	       "; ",
	       ## Prefer date in ISO 8601 format, UTC.
	       format(Sys.time(), tz = "UTC", usetz = TRUE),
	       ## Sys.time(),
	       "; ",
	       .OStype())

    ## At some point of time, we had:
    ##   We must not split the Built: field across lines.
    ## Not sure if this is still true.  If not, the following could be
    ## simplified to
    ##   db["Built"] <- Built
    ##   write.dcf(rbind(db), file.path(outDir, "DESCRIPTION"))
    ## But in any case, it is true for fields obtained from expanding R
    ## fields (Authors@R): these should not be reformatted.

    db <- c(db,
            .expand_package_description_db_R_fields(db),
            Built = Built)

    ## This cannot be done in a MBCS: write.dcf fails
    ctype <- Sys.getlocale("LC_CTYPE")
    Sys.setlocale("LC_CTYPE", "C")
    on.exit(Sys.setlocale("LC_CTYPE", ctype))
    .write_description(db, file.path(outDir, "DESCRIPTION"))

    outMetaDir <- file.path(outDir, "Meta")
    if(!file_test("-d", outMetaDir) && !dir.create(outMetaDir))
         stop(gettextf("cannot open directory '%s'",
                       outMetaDir),
              domain = NA)
    saveInfo <- .split_description(db)
    saveRDS(saveInfo, file.path(outMetaDir, "package.rds"))

    invisible()
}

### * .split_description

## also used in .getRequiredPackages
.split_description <-
function(db, verbose = FALSE)
{
    if(!is.na(Built <- db["Built"])) {
        Built <- as.list(strsplit(Built, "; ")[[1L]])
        if(length(Built) != 4L) {
            warning(gettextf("*** someone has corrupted the Built field in package '%s' ***",
                             db["Package"]),
                    domain = NA,
                    call. = FALSE)
            Built <- NULL
        } else {
            names(Built) <- c("R", "Platform", "Date", "OStype")
            Built[["R"]] <- R_system_version(sub("^R ([0-9.]+)", "\\1",
                                                 Built[["R"]]))
        }
    } else Built <- NULL
    ## might perhaps have multiple entries
    Depends <- .split_dependencies(db[names(db) %in% "Depends"])
    ## several packages 'Depends' on base!
    ind <- match("base", names(Depends), 0L)
    if(ind) Depends <- Depends[-ind]
    ## We only need Rdepends for R < 2.7.0, but we still need to be
    ## able to check that someone is not trying to load this into a
    ## very old version of R.
    if("R" %in% names(Depends)) {
        Rdeps2 <- Depends["R" == names(Depends)]
        names(Rdeps2) <- NULL
        Rdeps <- Depends[["R", exact = TRUE]] # the first one
        Depends <- Depends[names(Depends) != "R"]
        ## several packages have 'Depends: R', which is a noop.
        if(verbose && length(Rdeps) == 1L)
             message("WARNING: omitting pointless dependence on 'R' without a version requirement")
        if(length(Rdeps) <= 1L) Rdeps <- NULL
    } else Rdeps2 <- Rdeps <- NULL
    Rdeps <- as.vector(Rdeps)
    Suggests <- .split_dependencies(db[names(db) %in% "Suggests"])
    Imports <- .split_dependencies(db[names(db) %in% "Imports"])
    LinkingTo <- .split_dependencies(db[names(db) %in% "LinkingTo"])
    structure(list(DESCRIPTION = db, Built = Built,
                   Rdepends = Rdeps, Rdepends2 = Rdeps2,
                   Depends = Depends, Suggests = Suggests,
                   Imports = Imports, LinkingTo = LinkingTo),
              class = "packageDescription2")
}

### * .vinstall_package_descriptions_as_RDS

## called from src/library/Makefile
.vinstall_package_descriptions_as_RDS <-
function(dir, packages)
{
    ## For the given packages installed in @file{dir}, install their
    ## DESCRIPTION package metadata as R metadata.
    ## Really only useful for base packages under Unix.
    ## See @file{src/library/Makefile.in}.

    for(p in unlist(strsplit(packages, "[[:space:]]+"))) {
        meta_dir <- file.path(dir, p, "Meta")
        if(!file_test("-d", meta_dir) && !dir.create(meta_dir))
            stop(gettextf("cannot open directory '%s'", meta_dir))
        package_info_dcf_file <- file.path(dir, p, "DESCRIPTION")
        package_info_rds_file <- file.path(meta_dir, "package.rds")
        if(file_test("-nt",
                     package_info_rds_file,
                     package_info_dcf_file))
            next
        saveRDS(.split_description(.read_description(package_info_dcf_file)),
                 package_info_rds_file)
    }
    invisible()
}

### * .update_package_rds

## not used
.update_package_rds <-
function(lib.loc = NULL)
{
    ## rebuild the dumped package descriptions for all packages in lib.loc
    if (is.null(lib.loc)) lib.loc <- .libPaths()
    lib.loc <- lib.loc[file.exists(lib.loc)]
    for (lib in lib.loc) {
        a <- list.files(lib, all.files = FALSE, full.names = TRUE)
        for (nam in a) {
            dfile <- file.path(nam, "DESCRIPTION")
            if (file.exists(dfile)) {
                print(nam)
                .install_package_description(nam, nam)
            }
        }
    }
}

### * .install_package_code_files

.install_package_code_files <-
function(dir, outDir)
{
    if(!file_test("-d", dir))
        stop(gettextf("directory '%s' does not exist", dir),
             domain = NA)
    dir <- file_path_as_absolute(dir)

    ## Attempt to set the LC_COLLATE locale to 'C' to turn off locale
    ## specific sorting.
    curLocale <- Sys.getlocale("LC_COLLATE")
    on.exit(Sys.setlocale("LC_COLLATE", curLocale), add = TRUE)
    ## (Guaranteed to work as per the Sys.setlocale() docs.)
    lccollate <- "C"
    if(Sys.setlocale("LC_COLLATE", lccollate) != lccollate) {
        ## <NOTE>
        ## I don't think we can give an error here.
        ## It may be the case that Sys.setlocale() fails because the "OS
        ## reports request cannot be honored" (src/main/platform.c), in
        ## which case we should still proceed ...
        warning("cannot turn off locale-specific sorting via LC_COLLATE")
        ## </NOTE>
    }

    ## We definitely need a valid DESCRIPTION file.
    db <- .read_description(file.path(dir, "DESCRIPTION"))

    codeDir <- file.path(dir, "R")
    if(!file_test("-d", codeDir)) return(invisible())

    codeFiles <- list_files_with_type(codeDir, "code", full.names = FALSE)

    collationField <-
        c(paste("Collate", .OStype(), sep = "."), "Collate")
    if(any(i <- collationField %in% names(db))) {
        collationField <- collationField[i][1L]
        codeFilesInCspec <- .read_collate_field(db[collationField])
        ## Duplicated entries in the collation spec?
        badFiles <-
            unique(codeFilesInCspec[duplicated(codeFilesInCspec)])
        if(length(badFiles)) {
            out <- gettextf("\nduplicated files in '%s' field:",
                            collationField)
            out <- paste(out,
                         paste(" ", badFiles, collapse = "\n"),
                         sep = "\n")
            stop(out, domain = NA)
        }
        ## See which files are listed in the collation spec but don't
        ## exist.
        badFiles <- setdiff(codeFilesInCspec, codeFiles)
        if(length(badFiles)) {
            out <- gettextf("\nfiles in '%s' field missing from '%s':",
                            collationField,
                            codeDir)
            out <- paste(out,
                         paste(" ", badFiles, collapse = "\n"),
                         sep = "\n")
            stop(out, domain = NA)
        }
        ## See which files exist but are missing from the collation
        ## spec.  Note that we do not want the collation spec to use
        ## only a subset of the available code files.
        badFiles <- setdiff(codeFiles, codeFilesInCspec)
        if(length(badFiles)) {
            out <- gettextf("\nfiles in '%s' missing from '%s' field:",
                            codeDir,
                            collationField)
            out <- paste(out,
                         paste(" ", badFiles, collapse = "\n"),
                         sep = "\n")
            stop(out, domain = NA)
        }
        ## Everything's groovy ...
        codeFiles <- codeFilesInCspec
    }

    codeFiles <- file.path(codeDir, codeFiles)

    if(!file_test("-d", outDir) && !dir.create(outDir))
        stop(gettextf("cannot open directory '%s'", outDir),
             domain = NA)
    outCodeDir <- file.path(outDir, "R")
    if(!file_test("-d", outCodeDir) && !dir.create(outCodeDir))
        stop(gettextf("cannot open directory '%s'", outCodeDir),
             domain = NA)
    outFile <- file.path(outCodeDir, db["Package"])
    if(!file.create(outFile))
        stop(gettextf("unable to create '%s'", outFile), domain = NA)
    writeLines(paste0(".packageName <- \"", db["Package"], "\""),
               outFile)
    enc <- as.vector(db["Encoding"])
    need_enc <- !is.na(enc) # Encoding was specified
    ## assume that if locale is 'C' we can used 8-bit encodings unchanged.
    if(need_enc && !(Sys.getlocale("LC_CTYPE") %in% c("C", "POSIX"))) {
        con <- file(outFile, "a")
        on.exit(close(con))  # Windows does not like files left open
        for(f in codeFiles) {
            tmp <- iconv(readLines(f, warn = FALSE), from = enc, to = "")
            if(length(bad <- which(is.na(tmp)))) {
                warning(sprintf(ngettext(length(bad),
                                         "unable to re-encode %s line %s",
                                         "unable to re-encode %s lines %s"),
                                sQuote(basename(f)),
                                paste(bad, collapse = ", ")),
                        domain = NA, call. = FALSE)
                tmp <- iconv(readLines(f, warn = FALSE), from = enc, to = "",
                             sub = "byte")
            }
            writeLines(paste0("#line 1 \"", f, "\""), con)
            writeLines(tmp, con)
        }
	close(con); on.exit()
    } else {
        ## <NOTE>
        ## It may be safer to do
        ##   writeLines(sapply(codeFiles, readLines), outFile)
        ## instead, but this would be much slower ...
        ## use fast version of file.append that ensures LF between files
        if(!all(.file_append_ensuring_LFs(outFile, codeFiles)))
            stop("unable to write code files")
        ## </NOTE>
    }
    ## A syntax check here, so that we do not install a broken package.
    ## FIXME:  this is only needed if we don't lazy load, as the lazy loader
    ## would detect the error.
    op <- options(showErrorCalls=FALSE)
    on.exit(options(op))
    parse(outFile)
    invisible()
}


### * .install_package_indices
## called from R CMD INSTALL

.install_package_indices <-
function(dir, outDir)
{
    options(warn = 1)                   # to ensure warnings get seen
    if(!file_test("-d", dir))
        stop(gettextf("directory '%s' does not exist", dir),
             domain = NA)
    if(!file_test("-d", outDir))
        stop(gettextf("directory '%s' does not exist", outDir),
             domain = NA)

    ## If there is an @file{INDEX} file in the package sources, we
    ## install this, and do not build it.
    if(file_test("-f", file.path(dir, "INDEX")))
        if(!file.copy(file.path(dir, "INDEX"),
                      file.path(outDir, "INDEX"),
                      overwrite = TRUE))
            stop(gettextf("unable to copy INDEX to '%s'",
                          file.path(outDir, "INDEX")),
                 domain = NA)

    outMetaDir <- file.path(outDir, "Meta")
    if(!file_test("-d", outMetaDir) && !dir.create(outMetaDir))
         stop(gettextf("cannot open directory '%s'", outMetaDir),
              domain = NA)
    .install_package_Rd_indices(dir, outDir)
    .install_package_demo_index(dir, outDir)
    invisible()
}

### * .install_package_Rd_indices

.install_package_Rd_indices <-
function(dir, outDir)
{
    dir <- file_path_as_absolute(dir)
    docsDir <- file.path(dir, "man")
    dataDir <- file.path(outDir, "data")
    outDir <- file_path_as_absolute(outDir)

    ## <FIXME>
    ## Not clear whether we should use the basename of the directory we
    ## install to, or the package name as obtained from the DESCRIPTION
    ## file in the directory we install from (different for versioned
    ## installs).  We definitely do not want the basename of the dir we
    ## install from.
    packageName <- basename(outDir)
    ## </FIXME>

    allRd <- if(file_test("-d", docsDir))
        list_files_with_type(docsDir, "docs") else character()
    ## some people have man dirs without any valid .Rd files
    if(length(allRd)) {
        ## we want the date of the newest .Rd file we will install
        newestRd <- max(file.info(allRd)$mtime)
        ## these files need not exist, which gives NA.
        indices <- c(file.path("Meta", "Rd.rds"),
                     file.path("Meta", "hsearch.rds"),
                     file.path("Meta", "links.rds"),
                     "INDEX")
        upToDate <- file.info(file.path(outDir, indices))$mtime >= newestRd
        if(file_test("-d", dataDir)
           && length(dataFiles <- list.files(dataDir))) {
            ## Note that the data index is computed from both the package's
            ## Rd files and the data sets actually available.
            newestData <- max(file.info(dataFiles)$mtime)
            upToDate <- c(upToDate,
                          file.info(file.path(outDir, "Meta", "data.rds"))$mtime >=
                          max(newestRd, newestData))
        }
        ## Note that this is not quite good enough: an Rd file or data file
        ## might have been removed since the indices were made.
        RdsFile <- file.path("Meta", "Rd.rds")
        if(file.exists(RdsFile)) { ## for Rd files
            ## this has file names without path
            files <- readRDS(RdsFile)$File
            if(!identical(basename(allRd), files)) upToDate <- FALSE
        }
        ## we want to proceed if any is NA.
        if(all(upToDate %in% TRUE)) return(invisible())

        ## Rd objects should already have been installed.
        db <- tryCatch(Rd_db(basename(outDir), lib.loc = dirname(outDir)),
                       error = function(e) NULL)
        ## If not, we build the Rd db from the sources:
        if(is.null(db)) db <- .build_Rd_db(dir, allRd)
        contents <- Rd_contents(db)

        .write_Rd_contents_as_RDS(contents,
                                  file.path(outDir, "Meta", "Rd.rds"))

        defaultEncoding <- as.vector(readRDS(file.path(outDir, "Meta", "package.rds"))$DESCRIPTION["Encoding"])
        if(is.na(defaultEncoding)) defaultEncoding <- NULL
        saveRDS(.build_hsearch_index(contents, packageName, defaultEncoding),
                 file.path(outDir, "Meta", "hsearch.rds"))

        saveRDS(.build_links_index(contents, packageName),
                 file.path(outDir, "Meta", "links.rds"))

        ## If there is no @file{INDEX} file in the package sources, we
        ## build one.
        ## <NOTE>
        ## We currently do not also save this in RDS format, as we can
        ## always do
        ##   .build_Rd_index(readRDS(file.path(outDir, "Meta", "Rd.rds"))
        if(!file_test("-f", file.path(dir, "INDEX")))
            writeLines(formatDL(.build_Rd_index(contents)),
                       file.path(outDir, "INDEX"))
        ## </NOTE>
    } else {
        contents <- NULL
        saveRDS(.build_hsearch_index(contents, packageName, defaultEncoding),
                 file.path(outDir, "Meta", "hsearch.rds"))

        saveRDS(.build_links_index(contents, packageName),
                 file.path(outDir, "Meta", "links.rds"))

    }
    if(file_test("-d", dataDir))
        saveRDS(.build_data_index(dataDir, contents),
                 file.path(outDir, "Meta", "data.rds"))
    invisible()
}

### * .install_package_vignettes2
## called from R CMD INSTALL for pre 3.0.2-built tarballs, and for base packages

.install_package_vignettes2 <-
function(dir, outDir, encoding = "")
{
    dir <- file_path_as_absolute(dir)
    subdirs <- c("vignettes", file.path("inst", "doc"))
    ok <- file_test("-d", file.path(dir, subdirs))
    ## Create a vignette index only if the vignette dir exists.
    if (!any(ok))
       return(invisible())

    subdir <- subdirs[ok][1L]
    vignetteDir <- file.path(dir, subdir)

    outDir <- file_path_as_absolute(outDir)
    packageName <- basename(outDir)
    outVignetteDir <- file.path(outDir, "doc")
    ## --fake  and --no-inst installs do not have a outVignetteDir.
    if(!file_test("-d", outVignetteDir)) return(invisible())

    ## If there is an HTML index in the @file{inst/doc} subdirectory of
    ## the package source directory (@code{dir}), we do not overwrite it
    ## (similar to top-level @file{INDEX} files).  Installation already
    ## copied this over.
    hasHtmlIndex <- file_test("-f", file.path(vignetteDir, "index.html"))
    htmlIndex <- file.path(outDir, "doc", "index.html")

    vigns <- pkgVignettes(dir = dir, subdirs = subdir, check = TRUE)

    ## Write dummy HTML index if no vignettes are found and exit.
    if(length(vigns$docs) == 0L) {
        ## we don't want to write an index if the directory is in fact empty
        files <- list.files(vignetteDir, all.files = TRUE, no.. = TRUE)
        if((length(files) > 0L) && !hasHtmlIndex)
            .writeVignetteHtmlIndex(packageName, htmlIndex)
        return(invisible())
    }

    if (subdir == "vignettes") {
        ## copy vignette sources over.
        file.copy(vigns$docs, outVignetteDir)
    }

    vigns <- tryCatch({
        pkgVignettes(dir=outDir, subdirs="doc", output=TRUE, source=TRUE)
    }, error = function(ex) {
        pkgVignettes(dir=outDir, subdirs="doc")
    })

    vignetteIndex <- .build_vignette_index(vigns)
    if(NROW(vignetteIndex) > 0L) {
        cwd <- getwd()
        if (is.null(cwd))
            stop("current working directory cannot be ascertained")
        setwd(outVignetteDir)

	loadVignetteBuilder(dir, mustwork = FALSE)

        ## install tangled versions of Sweave vignettes.  FIXME:  Vignette
        ## *.R files should have been included when the package was built,
        ## but in the interim before they are all built with the new code,
        ## this is needed.
        for(i in seq_along(vigns$docs)) {
            file <- vigns$docs[i]
            if (!is.null(vigns$sources) && !is.null(vigns$sources[file][[1]]))
            	next
            file <- basename(file)
            enc <- getVignetteEncoding(file, TRUE)
            if(enc %in% c("non-ASCII", "unknown")) enc <- encoding

            cat("  ", sQuote(basename(file)),
                if(nzchar(enc)) paste("using", sQuote(enc)), "\n")

	    engine <- try(vignetteEngine(vigns$engines[i]), silent = TRUE)
	    if (!inherits(engine, "try-error"))
            	engine$tangle(file, quiet = TRUE, encoding = enc)
            setwd(outVignetteDir) # just in case some strange tangle function changed it
        }
        setwd(cwd)

        # Update - now from the output directory
        vigns <- pkgVignettes(dir=outDir, subdirs="doc", source=TRUE)

        ## remove any files with no R code (they will have header comments).
        ## if not correctly declared they might not be in the current encoding
        sources <- unlist(vigns$sources)
        for(i in seq_along(sources)) {
            file <- sources[i]
            if (!file_test("-f", file)) next
            bfr <- readLines(file, warn = FALSE)
            if(all(grepl("(^###|^[[:space:]]*$)", bfr, useBytes = TRUE)))
                unlink(file)
        }

        # Update
        vigns <- pkgVignettes(dir=outDir, subdirs="doc", source=TRUE)

        # Add tangle source files (*.R) to the vignette index
        # Only the "main" R file, because tangle may also split
        # output into multiple files
        sources <- character(length(vigns$docs))
        for (i in seq_along(vigns$docs)) {
           name <- vigns$names[i]
           source <- find_vignette_product(name, by = "tangle", main = TRUE, dir = vigns$dir, engine = engine)
           if (length(source) > 0L)
              sources[i] <- basename(source)
        }
        vignetteIndex$R <- sources
    }

    if(!hasHtmlIndex)
        .writeVignetteHtmlIndex(packageName, htmlIndex, vignetteIndex)

    saveRDS(vignetteIndex,
             file = file.path(outDir, "Meta", "vignette.rds"))

    invisible()
}

### * .install_package_vignettes3
## called from R CMD INSTALL for 3.0.2 or later tarballs

.install_package_vignettes3 <-
function(dir, outDir, encoding = "")
{
    packageName <- basename(outDir)
    dir <- file_path_as_absolute(dir)
    indexname <- file.path(dir, "build", "vignette.rds")
    ok <- file_test("-f", indexname)
    ## Create a vignette index only if the vignette dir exists.
    if (!ok)
       return(invisible())
       
    ## Copy the index to Meta
    file.copy(indexname, file.path(outDir, "Meta"))

    ## If there is an HTML index in the @file{inst/doc} subdirectory of
    ## the package source directory (@code{dir}), we do not overwrite it
    ## (similar to top-level @file{INDEX} files).  Installation already
    ## copied this over.
    vignetteDir <- file.path(outDir, "doc")
    hasHtmlIndex <- file_test("-f", file.path(vignetteDir, "index.html"))
    htmlIndex <- file.path(outDir, "doc", "index.html")

    vignetteIndex <- readRDS(indexname)

    if(!hasHtmlIndex)
        .writeVignetteHtmlIndex(packageName, htmlIndex, vignetteIndex)

    invisible()
}

### * .install_package_demo_index

.install_package_demo_index <-
function(dir, outDir)
{
    demoDir <- file.path(dir, "demo")
    if(!file_test("-d", demoDir)) return(invisible())
    demoIndex <- .build_demo_index(demoDir)
    saveRDS(demoIndex,
             file = file.path(outDir, "Meta", "demo.rds"))
    invisible()
}

### * .vinstall_package_indices

## called from src/library/Makefile
.vinstall_package_indices <-
function(src_dir, out_dir, packages)
{
    ## For the given packages with sources rooted at @file{src_dir} and
    ## installations rooted at @file{out_dir}, install the package
    ## indices.
    ## Really only useful for base packages under Unix.
    ## See @file{src/library/Makefile.in}.

    for(p in unlist(strsplit(packages, "[[:space:]]+")))
        .install_package_indices(file.path(src_dir, p), file.path(out_dir, p))
    utils::make.packages.html(.Library, verbose = FALSE)
    invisible()
}

### * .install_package_vignettes

## called from src/library/Makefile[.win]
## this is only used when building R
.install_package_vignettes <-
function(dir, outDir, keep.source = TRUE)
{
    dir <- file_path_as_absolute(dir)
    vigns <- pkgVignettes(dir = dir)
    if(is.null(vigns) || !length(vigns$docs)) return(invisible())

    outDir <- file_path_as_absolute(outDir)
    outVignetteDir <- file.path(outDir, "doc")
    if(!file_test("-d", outVignetteDir) && !dir.create(outVignetteDir))
        stop(gettextf("cannot open directory '%s'", outVignetteDir),
             domain = NA)

    ## We have to be careful to avoid repeated rebuilding.
    vignettePDFs <-
        file.path(outVignetteDir,
                  sub("$", ".pdf",
                      basename(file_path_sans_ext(vigns$docs))))
    upToDate <- file_test("-nt", vignettePDFs, vigns$docs)

    ## The primary use of this function is to build and install PDF
    ## vignettes in base packages.
    ## Hence, we build in a subdir of the current directory rather
    ## than a temp dir: this allows inspection of problems and
    ## automatic cleanup via Make.
    cwd <- getwd()
    if (is.null(cwd))
        stop("current working directory cannot be ascertained")
    buildDir <- file.path(cwd, ".vignettes")
    if(!file_test("-d", buildDir) && !dir.create(buildDir))
        stop(gettextf("cannot create directory '%s'", buildDir), domain = NA)
    on.exit(setwd(cwd))
    setwd(buildDir)

    loadVignetteBuilder(vigns$pkgdir)

    for(i in seq_along(vigns$docs)[!upToDate]) {
        file <- vigns$docs[i]
        name <- vigns$names[i]
        engine <- vignetteEngine(vigns$engines[i])

        message(gettextf("processing %s", sQuote(basename(file))),
                domain = NA)

        ## Note that contrary to all other weave/tangle calls, here
        ## 'file' is not a file in the current directory [hence no
        ## file <- basename(file) above]. However, weave should/must
        ## always create a file ('output') in the current directory.
        output <- tryCatch({
            engine$weave(file, pdf = TRUE, eps = FALSE, quiet = TRUE,
                        keep.source = keep.source, stylepath = FALSE)
            setwd(buildDir)
            find_vignette_product(name, by = "weave", engine = engine)
        }, error = function(e) {
            stop(gettextf("running %s on vignette '%s' failed with message:\n%s",
                 engine[["name"]], file, conditionMessage(e)),
                 domain = NA, call. = FALSE)
        })
        ## In case of an error, do not clean up: should we point to
        ## buildDir for possible inspection of results/problems?
        ## We need to ensure that vignetteDir is in TEXINPUTS and BIBINPUTS.
        if (vignette_is_tex(output)) {
	    ## <FIXME>
	    ## What if this fails?
            ## Now gives a more informative error texi2pdf fails
            ## or if it does not produce a <name>.pdf.
            tryCatch({
                texi2pdf(file = output, quiet = TRUE, texinputs = vigns$dir)
                output <- find_vignette_product(name, by = "texi2pdf", engine = engine)
            }, error = function(e) {
                stop(gettextf("compiling TeX file %s failed with message:\n%s",
                 sQuote(output), conditionMessage(e)),
                 domain = NA, call. = FALSE)
            })
	    ## </FIXME>
	}

        if(!file.copy(output, outVignetteDir, overwrite = TRUE))
            stop(gettextf("cannot copy '%s' to '%s'",
                          output,
                          outVignetteDir),
                 domain = NA)
    }
    ## Need to change out of this dir before we delete it,
    ## at least on Windows.
    setwd(cwd)
    unlink(buildDir, recursive = TRUE)
    ## Now you need to update the HTML index!
    ## This also creates the .R files
    .install_package_vignettes2(dir, outDir)    
    invisible()
}

### * .install_package_namespace_info

.install_package_namespace_info <-
function(dir, outDir)
{
    dir <- file_path_as_absolute(dir)
    nsFile <- file.path(dir, "NAMESPACE")
    if(!file_test("-f", nsFile)) return(invisible())
    nsInfoFilePath <- file.path(outDir, "Meta", "nsInfo.rds")
    if(file_test("-nt", nsInfoFilePath, nsFile)) return(invisible())
    nsInfo <- parseNamespaceFile(basename(dir), dirname(dir))
    outMetaDir <- file.path(outDir, "Meta")
    if(!file_test("-d", outMetaDir) && !dir.create(outMetaDir))
        stop(gettextf("cannot open directory '%s'", outMetaDir),
             domain = NA)
    saveRDS(nsInfo, nsInfoFilePath)
    invisible()
}

### * .vinstall_package_namespaces_as_RDS

## called from src/library/Makefile
.vinstall_package_namespaces_as_RDS <-
function(dir, packages)
{
    ## For the given packages installed in @file{dir} which have a
    ## NAMESPACE file, install the namespace info as R metadata.
    ## Really only useful for base packages under Unix.
    ## See @file{src/library/Makefile.in}.

    for(p in unlist(strsplit(packages, "[[:space:]]+")))
        .install_package_namespace_info(file.path(dir, p),
                                        file.path(dir, p))
    invisible()
}

### * .install_package_Rd_objects

## called from src/library/Makefile
.install_package_Rd_objects <-
function(dir, outDir, encoding = "unknown")
{
    dir <- file_path_as_absolute(dir)
    mandir <- file.path(dir, "man")
    manfiles <- if(!file_test("-d", mandir)) character()
    else list_files_with_type(mandir, "docs")
    manOutDir <- file.path(outDir, "help")
    dir.create(manOutDir, FALSE)
    db_file <- file.path(manOutDir,
                         paste0(basename(outDir), ".rdx"))
    built_file <- file.path(dir, "build", "partial.rdb")
    ## Avoid (costly) rebuilding if not needed.
    ## Actually, it seems no more costly than these tests, which it also does
    pathsFile <- file.path(manOutDir, "paths.rds")
    if(!file_test("-f", db_file) || !file.exists(pathsFile) ||
       !identical(sort(manfiles), sort(readRDS(pathsFile))) ||
       !all(file_test("-nt", db_file, manfiles))) {
        db <- .build_Rd_db(dir, manfiles, db_file = db_file,
                           encoding = encoding, built_file = built_file)
        nm <- as.character(names(db)) # Might be NULL
        saveRDS(structure(nm,
                          first = nchar(file.path(mandir, "")) + 1L),
                pathsFile)
        names(db) <- sub("\\.[Rr]d$", "", basename(nm))
        makeLazyLoadDB(db, file.path(manOutDir, basename(outDir)))
    }
    invisible()
}

### * .install_package_demos

## called from basepkg.mk and .install_packages
.install_package_demos <-
function(dir, outDir)
{
    ## NB: we no longer install 00Index
    demodir <- file.path(dir, "demo")
    if(!file_test("-d", demodir)) return()
    demofiles <- list_files_with_type(demodir, "demo", full.names = FALSE)
    if(!length(demofiles)) return()
    demoOutDir <- file.path(outDir, "demo")
    if(!file_test("-d", demoOutDir)) dir.create(demoOutDir)
    file.copy(file.path(demodir, demofiles), demoOutDir,
              overwrite = TRUE)
}


### * .find_cinclude_paths

.find_cinclude_paths <-
function(pkgs, lib.loc = NULL, file = NULL)
{
    ## given a character string of comma-separated package names,
    ## find where the packages are installed and generate
    ## -I"/path/to/package/include" ...

    if(!is.null(file)) {
        tmp <- read.dcf(file, "LinkingTo")[1L, 1L]
        if(is.na(tmp)) return(invisible())
        pkgs <- tmp
    }
    pkgs <- strsplit(pkgs[1L], ",[[:blank:]]*")[[1L]]
    paths <- find.package(pkgs, lib.loc, quiet=TRUE)
    if(length(paths))
	cat(paste(paste0('-I"', paths, '/include"'), collapse=" "))
    return(invisible())
}

### * .Rtest_package_depends_R_version

.Rtest_package_depends_R_version <-
function(dir)
{
    if(missing(dir)) dir <- "."
    meta <- .read_description(file.path(dir, "DESCRIPTION"))
    deps <- .split_description(meta, verbose = TRUE)$Rdepends2
    status <- 0
    current <- getRversion()
    for(depends in deps) {
        ## .split_description will have ensured that this is NULL or
        ## of length 3.
        if(length(depends) > 1L) {
            ## .check_package_description will insist on these operators
            if(!depends$op %in% c("<=", ">=", "<", ">", "==", "!="))
                message("WARNING: malformed 'Depends' field in 'DESCRIPTION'")
            else {
                status <- if(inherits(depends$version, "numeric_version"))
                    !do.call(depends$op, list(current, depends$version))
                else {
                    ver <- R.version
                    if (ver$status %in% c("", "Patched")) FALSE
                    else !do.call(depends$op,
                                 list(ver[["svn rev"]],
                                      as.numeric(sub("^r", "", depends$version))))
                }
            }
            if(status != 0) {
                package <- Sys.getenv("R_PACKAGE_NAME")
                if(!nzchar(package))
                    package <- meta["Package"]
                msg <- if(nzchar(package))
                    gettextf("ERROR: this R is version %s, package '%s' requires R %s %s",
                                    current, package,
                                    depends$op, depends$version)
                else
                    gettextf("ERROR: this R is version %s, required is R %s %s",
                                    current, depends$op, depends$version)
                message(strwrap(msg, exdent = 2L))
                break
            }
        }
    }
    status
}

## no longer used
.test_package_depends_R_version <-
function(dir)
    q(status = .Rtest_package_depends_R_version(dir))


### * .test_load_package

.test_load_package <- function(pkg_name, lib)
{
    options(warn = 1)
    res <- try(suppressPackageStartupMessages(library(pkg_name, lib.loc = lib, character.only = TRUE, logical.return = TRUE)))
    if (inherits(res, "try-error") || !res)
        stop("loading failed", call. = FALSE)
}


### * checkRdaFiles

checkRdaFiles <- function(paths)
{
    if(length(paths) == 1L && isTRUE(file.info(paths)$isdir)) {
        paths <- Sys.glob(c(file.path(paths, "*.rda"),
                            file.path(paths, "*.RData")))
        ## Exclude .RData, which this may or may not match
        paths <- grep("/[.]RData$", paths, value = TRUE, invert = TRUE)
    }
    res <- data.frame(size = NA_real_, ASCII = NA,
                      compress = NA_character_, version = NA_integer_,
                      stringsAsFactors = FALSE)
    res <- res[rep_len(1L, length(paths)), ]
    row.names(res) <- paths
    keep <- file.exists(paths)
    res$size[keep] <- file.info(paths)$size[keep]
    for(p in paths[keep]) {
        magic <- readBin(p, "raw", n = 5)
        res[p, "compress"] <- if(all(magic[1:2] == c(0x1f, 0x8b))) "gzip"
        else if(rawToChar(magic[1:3]) == "BZh") "bzip2"
        else if(magic[1L] == 0xFD && rawToChar(magic[2:5]) == "7zXZ") "xz"
        else if(grepl("RD[ABX][12]", rawToChar(magic), useBytes = TRUE)) "none"
        else "unknown"
        con <- gzfile(p)
        magic <- readChar(con, 5L, useBytes = TRUE)
        close(con)
        res[p, "ASCII"]  <- if (grepl("RD[ABX][12]", magic, useBytes = TRUE))
            substr(magic, 3, 3) == "A" else NA
        ver <- sub("(RD[ABX])([12]*)", "\\2", magic, useBytes = TRUE)
        res$version <- as.integer(ver)
    }
    res
}

### * resaveRdaFiles

resaveRdaFiles <- function(paths,
                           compress = c("auto", "gzip", "bzip2", "xz"),
                           compression_level)
{
    if(length(paths) == 1L && isTRUE(file.info(paths)$isdir))
        paths <- Sys.glob(c(file.path(paths, "*.rda"),
                            file.path(paths, "*.RData")))
    compress <- match.arg(compress)
    if (missing(compression_level))
        compression_level <- switch(compress, "gzip" = 6, 9)
    for(p in paths) {
        env <- new.env(hash = TRUE) # probably small, need not be
#        sink(tempfile()) ## suppress startup messages to stdout, for BARD
        suppressPackageStartupMessages(load(p, envir = env))
#        sink()
        if(compress == "auto") {
            f1 <- tempfile()
            save(file = f1, list = ls(env, all.names = TRUE), envir = env)
            f2 <- tempfile()
            save(file = f2, list = ls(env, all.names = TRUE), envir = env,
                 compress = "bzip2")
            ss <- file.info(c(f1, f2))$size * c(0.9, 1.0)
            names(ss) <- c(f1, f2)
            if(ss[1L] > 10240) {
                f3 <- tempfile()
                save(file = f3, list = ls(env, all.names = TRUE), envir = env,
                     compress = "xz")
                ss <- c(ss, file.info(f3)$size)
		names(ss) <- c(f1, f2, f3)
            }
            nm <- names(ss)
            ind <- which.min(ss)
            file.copy(nm[ind], p, overwrite = TRUE)
            unlink(nm)
        } else
            save(file = p, list = ls(env, all.names = TRUE), envir = env,
                 compress = compress, compression_level = compression_level)
    }
}

### * compactPDF

compactPDF <-
    function(paths, qpdf = Sys.which(Sys.getenv("R_QPDF", "qpdf")),
             gs_cmd = Sys.getenv("R_GSCMD", ""),
             gs_quality = Sys.getenv("GS_QUALITY", "none"),
             gs_extras = character())
{
    use_qpdf <- nzchar(qpdf)
    gs_quality <- match.arg(gs_quality, c("none", "printer", "ebook", "screen"))
    use_gs <- if(gs_quality != "none") nzchar(gs_cmd <- find_gs_cmd(gs_cmd)) else FALSE
    if (!use_gs && !use_qpdf) return()
    if(length(paths) == 1L && isTRUE(file.info(paths)$isdir))
        paths <- Sys.glob(file.path(paths, "*.pdf"))
    dummy <- rep.int(NA_real_, length(paths))
    ans <- data.frame(old = dummy, new = dummy, row.names = paths)
    tf <- tempfile("pdf"); tf2 <- tempfile("pdf")
    for (p in paths) {
        res <- 0
        if (use_gs) {
            res <- system2(gs_cmd,
                           c("-q -dNOPAUSE -dBATCH -sDEVICE=pdfwrite",
                             sprintf("-dPDFSETTINGS=/%s", gs_quality),
                             "-dCompatibilityLevel=1.5",
                             "-dAutoRotatePages=/None",
                             sprintf("-sOutputFile=%s", tf),
                             gs_extras, p), FALSE, FALSE)
            if(!res && use_qpdf) {
                unlink(tf2) # precaution
                file.rename(tf, tf2)
                res <- system2(qpdf, c("--stream-data=compress",
                                       "--object-streams=generate",
                                       tf2, tf), FALSE, FALSE)
                unlink(tf2)
            }
        } else if(use_qpdf) {
            res <- system2(qpdf, c("--stream-data=compress",
                                   "--object-streams=generate",
                                   p, tf), FALSE, FALSE)
        }
        if(!res && file.exists(tf)) {
            old <- file.info(p)$size; new <-  file.info(tf)$size
            if(new/old < 0.9 && new < old - 1e4) {
                file.copy(tf, p, overwrite = TRUE)
                ans[p, ] <- c(old, new)
            }
        }
        unlink(tf)
    }
    structure(na.omit(ans), class = c("compactPDF", "data.frame"))
}

find_gs_cmd <- function(gs_cmd = "")
{
    if(!nzchar(gs_cmd)) {
        if(.Platform$OS.type == "windows") {
            gsexe <- Sys.getenv("R_GSCMD")
            if (!nzchar(gsexe)) gsexe <- Sys.getenv("GSC")
            gs_cmd <- Sys.which(gsexe)
            if (!nzchar(gs_cmd)) gs_cmd <- Sys.which("gswin64c")
            if (!nzchar(gs_cmd)) gs_cmd <- Sys.which("gswin32c")
            gs_cmd
        } else Sys.which(Sys.getenv("R_GSCMD", "gs"))
    } else Sys.which(gs_cmd)
}

format.compactPDF <- function(x, ratio = 0.9, diff = 1e4, ...)
{
    if(!nrow(x)) return(character())
    z <- y <- x[with(x, new/old < ratio & new < old - diff), ]
    if(!nrow(z)) return(character())
    z[] <- lapply(y, function(x) sprintf("%.0fKb", x/1024))
    large <- y$new >= 1024^2
    z[large, ] <- lapply(y[large, ], function(x) sprintf("%.1fMb", x/1024^2))
    paste('  compacted', sQuote(basename(row.names(y))),
          'from', z[, 1L], 'to', z[, 2L])
}

### * add_datalist

add_datalist <- function(pkgpath, force = FALSE)
{
    dlist <- file.path(pkgpath, "data", "datalist")
    if (!force && file.exists(dlist)) return()
    fi <- file.info(Sys.glob(file.path(pkgpath, "data", "*")))
    size <- sum(fi$size)
    if(size <= 1024^2) return()
    z <- suppressPackageStartupMessages(list_data_in_pkg(dataDir = file.path(pkgpath, "data"))) # for BARD
    if(!length(z)) return()
    con <- file(dlist, "w")
    for (nm in names(z)) {
        zz <- z[[nm]]
        if (length(zz) == 1L && zz == nm) writeLines(nm, con)
        else cat(nm, ": ", paste(zz, collapse = " "), "\n",
                 sep = "", file = con)
    }
    close(con)
    invisible()
}


### Local variables: ***
### mode: outline-minor ***
### outline-regexp: "### [*]+" ***
### End: ***
#  File src/library/tools/R/assertCondition.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 2013 The R 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 of the License, 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/

assertCondition <- function(expr, ...,
                            .exprString = .deparseTrim(substitute(expr), cutoff = 30L),
                            verbose = FALSE) {
    fe <- function(e)e
    getConds <- function(expr) {
	conds <- list()
	tryCatch(withCallingHandlers(expr,
				     warning = function(w) {
					 conds <<- c(conds, list(w))
					 invokeRestart("muffleWarning")
				     },
				     condition = function(cond)
					 conds <<- c(conds, list(cond))),
		 error = function(e)
		     conds <<- c(conds, list(e)))
	conds
    }
    conds <- if(nargs() > 1) c(...) # else NULL
    .Wanted <- if(nargs() > 1) paste(c(...), collapse = " or ") else "any condition"
    res <- getConds(expr)
    if(length(res)) {
	if(is.null(conds)) {
            if(verbose)
                message("assertConditon: Successfully caught a condition\n")
	    invisible(res)
        }
	else {
	    ii <- sapply(res, function(cond) any(class(cond) %in% conds))
	    if(any(ii)) {
                if(verbose) {
                    found <-
                        unique(sapply(res, function(cond) class(cond)[class(cond) %in% conds]))
                    message(sprintf("assertCondition: caught %s",
                                    paste(dQuote(found), collapse =", ")))
                }
		invisible(res)
            }
	    else {
                .got <- paste(unique((sapply(res, function(obj)class(obj)[[1]]))),
                                     collapse = ", ")
		stop(gettextf("Got %s in evaluating %s; wanted %s",
			      .got, .exprString, .Wanted))
            }
	}
    }
    else
	stop(gettextf("Failed to get %s in evaluating %s",
		      .Wanted, .exprString))
}

assertError <- function(expr, verbose = FALSE) {
    d.expr <- .deparseTrim(substitute(expr), cutoff = 30L)
    tryCatch(res <- assertCondition(expr, "error", .exprString = d.expr),
             error = function(e)
                 stop(gettextf("Failed to get error in evaluating %s", d.expr),
                      call. = FALSE)
             )
    if(verbose) {
        error <- res[ sapply(res, function(cond) "error" %in% class(cond)) ]
        message(sprintf("Asserted error: %s", error[[1]]$message))
    }
    invisible(res)
}

assertWarning <- function(expr, verbose = FALSE) {
    d.expr <- .deparseTrim(substitute(expr), cutoff = 30L)
    res <- assertCondition(expr, "warning", .exprString = d.expr)
    if(any(sapply(res, function(cond) "error" %in% class(cond))))
        stop(gettextf("Got warning in evaluating %s, but also an error", d.expr))
    if(verbose) {
        warning <- res[ sapply(res, function(cond) "warning" %in% class(cond)) ]
        message(sprintf("Asserted warning: %s", warning[[1]]$message))
    }
    invisible(res)
}

.deparseTrim <- function(expr, cutoff = 30L) {
    res <- deparse(expr)
    if(length(res) > 1) {
        if(res[[1]] == "{") {
            exprs <- sub("^[ \t]*", "", res[c(-1, -length(res))])
            res <- paste0("{", paste(exprs, collapse = "; "), "}")
        }
        else
            res <- paste(res[[1]], " ...")
    }
    if(nchar(res) > cutoff)
        paste(substr(res, 1, cutoff), " ...")
    else
        res
}
#  File src/library/tools/R/bibstyle.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/

# Functions for making Rd and human readable versions of bibentry records.

# Clean up LaTeX accents and braces
cleanupLatex <- function(x) {
    if (!length(x)) return(x)
    latex <- tryCatch(parseLatex(x), error = function(e)e)
    if (inherits(latex, "error")) {
    	x
    } else {
    	deparseLatex(latexToUtf8(latex), dropBraces=TRUE)
    }
}

makeJSS <- function()
    local({

	# First, some utilities

	collapse <- function(strings)
	    paste(strings, collapse="\n")

	# Add a period if there's no sentence punctuation already
	addPeriod <- function(string)
	    sub("([^.?!])$", "\\1.", string)

	# Separate args by sep, add a period at the end.
	sentence <- function(..., sep = ", ") {
	    strings <- c(...)
	    if (length(strings)) {
		addPeriod(paste(strings, collapse = sep))
	    }
	}

	# Now some simple markup

	plain <- function(pages)
	    if (length(pages)) collapse(pages)

	plainclean <- function(s) plain(cleanupLatex(s))

	emph <- function(s)
	    if (length(s)) paste0("\\emph{", collapse(s), "}")

        emphclean <- function(s) emph(cleanupLatex(s))

	# This creates a function to label a field by adding a prefix or suffix (or both)

	label <- function(prefix=NULL, suffix=NULL, style=plain) {
	    force(prefix); force(suffix); force(style)
	    function(s)
		if (length(s)) style(paste0(prefix, collapse(s), suffix))
	}

	labelclean <- function(prefix=NULL, suffix=NULL, style=plain) {
	    f <- label(prefix, suffix, style)
	    function(s) f(cleanupLatex(s))
	}

	# Now the formatters for each particular field.  These take
	# a character vector; if length zero, they return NULL, otherwise
	# a single element character vector putting everything together

	fmtAddress <- plainclean
	fmtBook <- emphclean
	fmtBtitle <- emphclean
	fmtChapter <- labelclean(prefix="chapter ")
	fmtDOI <- label(prefix="\\url{http://dx.doi.org/", suffix="}")
	fmtEdition <- labelclean(suffix=" edition")
	fmtEprint <- plain
	fmtHowpublished <- plainclean
	fmtISBN <- label(prefix = "ISBN ")
	fmtISSN <- label(prefix="ISSN ")
	fmtInstitution <- plainclean
	fmtNote <- plainclean
	fmtPages <- label(prefix="pp. ")
	fmtSchool <- plainclean
	fmtTechreportnumber <- labelclean(prefix="Technical Report ")
	fmtUrl <- label(prefix="\\url{", suffix="}")
	fmtTitle <- function(title)
	    if (length(title))
                paste0("\\dQuote{",
                      addPeriod(collapse(cleanupLatex(title))), "}")

	fmtYear <- function(year) {
	    if (!length(year)) year <- "????"
	    paste0("(", collapse(year), ")")
	}

	# Now some more complicated ones that look at multiple fields
	volNum <- function(paper) {
	    if (length(paper$volume)) {
		result <- paste0("\\bold{", collapse(paper$volume), "}")
		if (length(paper$number))
		    result <- paste0(result, "(", collapse(paper$number), ")")
		result
	    }
	}

	## Format one person object in short "Murdoch DJ" format
	shortName <- function(person) {
	    if (length(person$family)) {
		result <- cleanupLatex(person$family)
		if (length(person$given))
		    paste(result,
			  paste(substr(sapply(person$given, cleanupLatex),
				       1, 1), collapse=""))
		else result
	    }
	    else
		paste(cleanupLatex(person$given), collapse=" ")
	}

	# Format all authors for one paper
	authorList <- function(paper) {
	    names <- sapply(paper$author, shortName)
	    if (length(names) > 1)
		result <- paste( paste(names[-length(names)], collapse=", "),
			    "and", names[length(names)])
	    else
		result <- names
	    result
	}

	# Format all editors for one paper
	editorList <- function(paper) {
	    names <- sapply(paper$editor, shortName)
	    if (length(names) > 1)
		result <- paste( paste(names[-length(names)], collapse=", "),
			    "and", names[length(names)], "(eds.)")
	    else if (length(names))
		result <- paste(names, "(ed.)")
	    else
		result <- NULL
	    result
	}

	extraInfo <- function(paper) {
	    result <- paste(c(fmtDOI(paper$doi), fmtNote(paper$note),
		  fmtEprint(paper$eprint), fmtUrl(paper$url)), collapse=", ")
	    if (result != "") result
	}

	bookVolume <- function(book) {
	    result <- ""
	    if (length(book$volume))
		result <- paste("volume", collapse(book$volume))
	    if (length(book$number))
		result <- paste(result, "number", collapse(book$number))
	    if (length(book$series))
		result <- paste(result, "series", collapse(book$series))
	    if (result != "") result
	}

	bookPublisher <- function(book) {
	    if (length(book$publisher)) {
		result <- collapse(book$publisher)
		if (length(book$address))
		    result <- paste(result, collapse(book$address), sep = ", ")
		result
	    }
	}

	procOrganization <- function(paper) {
	    if (length(paper$organization)) {
		result <- collapse(cleanupLatex(paper$organization))
		if (length(paper$address))
		    result <- paste(result, collapse(cleanupLatex(paper$address)), sep =", ")
		result
	    }
	}

	formatArticle <- function(paper) {
	    collapse(c(fmtPrefix(paper),
	             sentence(authorList(paper), fmtYear(paper$year), sep = " "),
		     fmtTitle(paper$title),
		     sentence(fmtBook(paper$journal), volNum(paper), fmtPages(paper$pages)),
		     sentence(fmtISSN(paper$issn), extraInfo(paper))))
	}

	formatBook <- function(book) {
	    authors <- authorList(book)
	    if(!length(authors))
		authors <- editorList(book)

	    collapse(c(fmtPrefix(book),
	               sentence(authors, fmtYear(book$year), sep = " "),
		       sentence(fmtBtitle(book$title), bookVolume(book), fmtEdition(book$edition)),
		       sentence(bookPublisher(book)),
		       sentence(fmtISBN(book$isbn), extraInfo(book))))
	}

	formatInbook <- function(paper) {
	    authors <- authorList(paper)
	    editors <- editorList(paper)
	    if(!length(authors)) {
		authors <- editors
		editors <- NULL
	    }
	    collapse(c(fmtPrefix(paper),
	               sentence(authors, fmtYear(paper$year), sep =" "),
		       fmtTitle(paper$title),
		       paste("In", sentence(editors, fmtBtitle(paper$booktitle), bookVolume(paper),
					    fmtChapter(paper$chapter),
					    fmtEdition(paper$edition), fmtPages(paper$pages))),
		       sentence(bookPublisher(paper)),
		       sentence(fmtISBN(paper$isbn), extraInfo(paper))))
	}

	formatIncollection <- function(paper) {
	    collapse(c(fmtPrefix(paper),
	               sentence(authorList(paper), fmtYear(paper$year), sep = " "),
		       fmtTitle(paper$title),
		       paste("In", sentence(editorList(paper), fmtBtitle(paper$booktitle), bookVolume(paper),
					    fmtEdition(paper$edition), fmtPages(paper$pages))),
		       sentence(bookPublisher(paper)),
		       sentence(fmtISBN(paper$isbn), extraInfo(paper))))
	}

	formatInProceedings <- function(paper)
	    collapse(c(fmtPrefix(paper),
	               sentence(authorList(paper), fmtYear(paper$year), sep = " "),
		       fmtTitle(paper$title),
		       paste("In", sentence(editorList(paper), fmtBtitle(paper$booktitle), bookVolume(paper),
					    fmtEdition(paper$edition), fmtPages(paper$pages))),
		       sentence(procOrganization(paper)),
		       sentence(fmtISBN(paper$isbn), extraInfo(paper))))

	formatManual <- function(paper) {
	    collapse(c(fmtPrefix(paper),
	               sentence(authorList(paper), fmtYear(paper$year), sep = " "),
		       sentence(fmtBtitle(paper$title), bookVolume(paper), fmtEdition(paper$edition)),
		       sentence(procOrganization(paper)),
		       sentence(fmtISBN(paper$isbn), extraInfo(paper))))
	}

	formatMastersthesis <- function(paper) {
	    collapse(c(fmtPrefix(paper),
	               sentence(authorList(paper), fmtYear(paper$year), sep = " "),
		       sentence(fmtBtitle(paper$title)),
		       sentence("Master's thesis", fmtSchool(paper$school), fmtAddress(paper$address)),
		       sentence(extraInfo(paper))))
	}

	formatPhdthesis <- function(paper) {
	    collapse(c(fmtPrefix(paper),
	    	       sentence(authorList(paper), fmtYear(paper$year), sep = " "),
		       sentence(fmtBtitle(paper$title)),
		       sentence("PhD thesis", fmtSchool(paper$school), fmtAddress(paper$address)),
		       sentence(extraInfo(paper))))
	}

	formatMisc <- function(paper) {
	    collapse(c(fmtPrefix(paper),
	               sentence(authorList(paper), fmtYear(paper$year), sep = " "),
		       fmtTitle(paper$title),
		       sentence(fmtHowpublished(paper$howpublished)),
		       sentence(extraInfo(paper))))
	}

	formatProceedings <- function(book) {
	    if (is.null(book$editor)) editor <- "Anonymous (ed.)"
	    else editor <- editorList(book)
	    collapse(c(fmtPrefix(book), # not paper
	    	       sentence(editor, fmtYear(book$year), sep = " "),
		       sentence(fmtBtitle(book$title), bookVolume(book)),
		       sentence(procOrganization(book)),
		       sentence(fmtISBN(book$isbn), fmtISSN(book$issn),
				extraInfo(book))))
	}

	formatTechreport <- function(paper) {
	    collapse(c(fmtPrefix(paper),
	    	       sentence(authorList(paper), fmtYear(paper$year), sep = " "),
		       fmtTitle(paper$title),
		       sentence(fmtTechreportnumber(paper$number),
				fmtInstitution(paper$institution),
				fmtAddress(paper$address)),
		       sentence(extraInfo(paper))))
	}

	formatUnpublished <- function(paper) {
	    collapse(c(fmtPrefix(paper),
	    	       sentence(authorList(paper), fmtYear(paper$year), sep = " "),
		       fmtTitle(paper$title),
		       sentence(extraInfo(paper))))
	}

	sortKeys <- function(bib) {
	    result <- character(length(bib))
	    for (i in seq_along(bib)) {
		authors <- authorList(bib[[i]])
		if (!length(authors))
		    authors <- editorList(bib[[i]])
		if (!length(authors))
		    authors <- ""
		result[i] <- authors
	    }
	    result
	}

	# Replace this if you want a bibliography style
	# that puts a prefix on each entry, e.g. [n]
	# The formatting routine will have added a field .index
	# as a 1-based index within the complete list.

	fmtPrefix <- function(paper) NULL

	cite <- function(key, bib, ...)
	    utils::citeNatbib(key, bib, ...) # the defaults are JSS style

	environment()
    })

bibstyle <- local({
    styles <- list(JSS = makeJSS())
    default <- "JSS"
    function(style, envir, ..., .init = FALSE, .default=TRUE) {
        newfns <- list(...)
        if (missing(style) || is.null(style)) {
            if (!missing(envir) || length(newfns) || .init)
            	stop("Changes require specified 'style'")
            style <- default
        } else {
	    if (!missing(envir)) {
		stopifnot(!.init)
		styles[[style]] <<- envir
	    }
	    if (.init) styles[[style]] <<- makeJSS()
	    if (length(newfns) && style == "JSS")
		stop("The default JSS style may not be modified.")
	    for (n in names(newfns))
		assign(n, newfns[[n]], envir=styles[[style]])
            if (.default)
            	default <<- style
        }
        styles[[style]]
    }
})

getBibstyle <- function(all = FALSE) {
    if (all)
    	names(environment(bibstyle)$styles)
    else
    	environment(bibstyle)$default
}

toRd.bibentry <- function(obj, style=NULL, ...) {
    obj <- sort(obj, .bibstyle=style)
    style <- bibstyle(style)
    env <- new.env(hash = FALSE, parent = style)
    bib <- unclass(obj)
    result <- character(length(bib))
    for (i in seq_along(bib)) {
    	env$paper <- bib[[i]]
    	result[i] <- with(env,
    	    switch(attr(paper, "bibtype"),
    	    Article = formatArticle(paper),
    	    Book = formatBook(paper),
    	    InBook = formatInbook(paper),
    	    InCollection = formatIncollection(paper),
    	    InProceedings = formatInProceedings(paper),
    	    Manual = formatManual(paper),
    	    MastersThesis = formatMastersthesis(paper),
    	    Misc = formatMisc(paper),
    	    PhdThesis = formatPhdthesis(paper),
    	    Proceedings = formatProceedings(paper),
    	    TechReport = formatTechreport(paper),
    	    Unpublished = formatUnpublished(paper),
    	    paste("bibtype", attr(paper, "bibtype"),"not implemented") ))
    }
    result
}
#  File src/library/tools/R/build.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R Core Team
#
# NB: also copyright date in Usage.
#
#  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 of the License, 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/

#### R based engine for R CMD build

## R developers can use this to debug the function by running it
## directly as tools:::.build_packages(args), where the args should
## be what commandArgs(TRUE) would return, that is a character vector
## of (space-delimited) terms that would be passed to R CMD build.

writeDefaultNamespace <-
function(filename, desc = file.path(dirname(filename), "DESCRIPTION"))
{
    pkgInfo <- .split_description(.read_description(desc))
    pkgs <- unique(c(names(pkgInfo$Imports), names(pkgInfo$Depends)))
    pkgs <- pkgs[pkgs != "base"]

    writeLines(c("# Default NAMESPACE created by R",
                 "# Remove the previous line if you edit this file",
    		 "",
    		 "# Export all names",
		 "exportPattern(\".\")",
		 if (length(pkgs))
		     c("",
		       "# Import all packages listed as Imports or Depends",
		       "import(",
		       paste(" ", pkgs, collapse = ",\n"),
		       ")")),
    	       filename)
}


### formerly Perl R::Utils::get_exclude_patterns

## Return list of file patterns excluded by R CMD build and check.
## Kept here so that we ensure that the lists are in sync, but not exported.
## Has Unix-style '/' path separators hard-coded, but that is what dir() uses.
get_exclude_patterns <- function()
    c("^\\.Rbuildignore$",
      "(^|/)\\.DS_Store$",
      "^\\.(RData|Rhistory)$",
      "~$", "\\.bak$", "\\.swp$",
      "(^|/)\\.#[^/]*$", "(^|/)#[^/]*#$",
      ## Outdated ...
      "^TITLE$", "^data/00Index$",
      "^inst/doc/00Index\\.dcf$",
      ## Autoconf
      "^config\\.(cache|log|status)$",
      "^autom4te\\.cache$",
      ## Windows dependency files
      "^src/.*\\.d$", "^src/Makedeps$",
      ## IRIX, of some vintage
      "^src/so_locations$",
      ## Sweave detrius
      "^inst/doc/Rplots\\.(ps|pdf)$"
      )


### based on Perl build script

.build_packages <- function(args = NULL)
{
    ## this requires on Windows sh make

    WINDOWS <- .Platform$OS.type == "windows"

    Sys.umask("022") # Perl version did not have this.

    writeLinesNL <- function(text, file)
    {
        ## a version that uses NL line endings everywhere
        con <- file(file, "wb")
        on.exit(close(con))
        writeLines(text, con)
    }

    ## This version of system_with_capture merges stdout and stderr
    ## Used to run R to install package and build vignettes.
    system_with_capture <- function (command, args) {
        outfile <- tempfile("xshell")
        on.exit(unlink(outfile))
        status <- system2(command, args, outfile, outfile)
        list(status = status, stdout = readLines(outfile, warn = FALSE))
    }
    ## Run silently
    Ssystem <- function(command, args = character(), ...)
        system2(command, args, stdout = NULL, stderr = NULL, ...)


    dir.exists <- function(x) !is.na(isdir <- file.info(x)$isdir) & isdir

    do_exit <- function(status = 1L) q("no", status = status, runLast = FALSE)

    env_path <- function(...) file.path(..., fsep = .Platform$path.sep)

    ## Used for BuildVignettes, BuildManual, BuildKeepEmpty,
    ## and (character not logical) BuildResaveData
    parse_description_field <-
        function(desc, field, default = TRUE, logical = TRUE)
    {
        tmp <- desc[field]
        if (is.na(tmp)) default
        else if(logical)
            switch(tmp,
                   "yes"=, "Yes" =, "true" =, "True" =, "TRUE" = TRUE,
                   "no" =, "No" =, "false" =, "False" =, "FALSE" = FALSE,
                   default)
        else tmp
    }

    Usage <- function() {
        cat("Usage: R CMD build [options] pkgdirs",
            "",
            "Build R packages from package sources in the directories specified by",
            sQuote("pkgdirs"),
            "",
            "Options:",
            "  -h, --help		print short help message and exit",
            "  -v, --version		print version info and exit",
            "",
            "  --force               force removal of INDEX file",
            "  --keep-empty-dirs     do not remove empty dirs",
            "  --no-build-vignettes  do not (re)build package vignettes",
            "  --no-manual           do not build the PDF manual even if \\Sexprs are present",
            "  --resave-data=        re-save data files as compactly as possible:",
            '                        "no", "best", "gzip" (default)',
            "  --resave-data         same as --resave-data=best",
            "  --no-resave-data      same as --resave-data=no",
            "  --compact-vignettes=  try to compact PDF files under inst/doc:",
            '                        "no" (default), "qpdf", "gs", "gs+qpdf", "both"',
            "  --compact-vignettes   same as --compact-vignettes=qpdf",
            "  --md5                 add MD5 sums",
           "",
            "Report bugs at bugs.r-project.org .", sep = "\n")
    }

    add_build_stamp_to_description_file <- function(ldpath) {
        db <- .read_description(ldpath)
        ## this is an optional function, so could fail
        user <- Sys.info()["user"]
        if(user == "unknown") user <- Sys.getenv("LOGNAME")
        db["Packaged"] <-
            sprintf("%s; %s",
                    format(Sys.time(), '', tz = 'UTC', usetz = TRUE),
                    user)
        .write_description(db, ldpath)
    }

    ## <FIXME>
    ## This should really be combined with
    ## add_build_stamp_to_description_file().
    ## Also, the build code reads DESCRIPTION files too often ...
    add_expanded_R_fields_to_description_file <- function(ldpath) {
        db <- .read_description(ldpath)
        fields <- .expand_package_description_db_R_fields(db)
        if(length(fields))
            .write_description(c(db, fields), ldpath)
    }
    ## </FIXME>

    temp_install_pkg <- function(pkgdir, libdir) {
	dir.create(libdir, mode = "0755", showWarnings = FALSE)
        ## assume vignettes only need one arch
        if (WINDOWS) {
            cmd <- file.path(R.home("bin"), "Rcmd.exe")
            args <- c("INSTALL -l", shQuote(libdir),
                      "--no-multiarch", shQuote(pkgdir))
        } else {
            cmd <- file.path(R.home("bin"), "R")
            args <- c("CMD", "INSTALL -l", shQuote(libdir),
                      "--no-multiarch", shQuote(pkgdir))
        }
	res <- system_with_capture(cmd, args)
	if (res$status) {
	    printLog(Log, "      -----------------------------------\n")
	    printLog0(Log, paste(c(res$stdout, ""),  collapse = "\n"))
	    printLog(Log, "      -----------------------------------\n")
	    unlink(libdir, recursive = TRUE)
	    printLog(Log, "ERROR: package installation failed\n")
	    do_exit(1)
	}
	TRUE
    }

    prepare_pkg <- function(pkgdir, desc, Log)
    {
        owd <- setwd(pkgdir); on.exit(setwd(owd))
        pkgname <- basename(pkgdir)
        checkingLog(Log, "DESCRIPTION meta-information")
        res <- try(.check_package_description("DESCRIPTION"))
        if (inherits(res, "try-error")) {
            resultLog(Log, "ERROR")
            messageLog(Log, "running '.check_package_description' failed")
        } else {
            if (any(sapply(res, length))) {
                resultLog(Log, "ERROR")
                print(res) # FIXME print to Log?
                do_exit(1L)
            } else resultLog(Log, "OK")
        }
        cleanup_pkg(pkgdir, Log)

        libdir <- tempfile("Rinst")

        ensure_installed <- function() {
	    if (!pkgInstalled) {
		messageLog(Log,
			   "installing the package to build vignettes")
		pkgInstalled <<- temp_install_pkg(pkgdir, libdir)
	    }
	}
        pkgInstalled <- build_Rd_db(pkgdir, libdir, desc)

        if (file.exists("INDEX")) update_Rd_index("INDEX", "man", Log)
        doc_dir <- file.path("inst", "doc")
        if ("makefile" %in% dir(doc_dir)) { # avoid case-insensitive match
            messageLog(Log, "renaming 'inst/doc/makefile' to 'inst/doc/Makefile'")
            file.rename(file.path(doc_dir, "makefile"),
                        file.path(doc_dir, "Makefile"))
        }
        if (vignettes &&
            parse_description_field(desc, "BuildVignettes", TRUE)) {
	    if (nchar(parse_description_field(desc, "VignetteBuilder", "")))
		ensure_installed()
            ## Look for vignette sources
            vigns <- pkgVignettes(dir = '.', check = TRUE)
            if (!is.null(vigns) && length(vigns$docs)) {
                ensure_installed()
                ## Good to do this in a separate process: it might die
                creatingLog(Log, "vignettes")
                R_LIBS <- Sys.getenv("R_LIBS", NA_character_)
                if (!is.na(R_LIBS)) {
                    on.exit(Sys.setenv(R_LIBS = R_LIBS), add = TRUE)
                    Sys.setenv(R_LIBS = env_path(libdir, R_LIBS))
                } else {
                    on.exit(Sys.unsetenv("R_LIBS"), add = TRUE)
                    Sys.setenv(R_LIBS = libdir)
                }

                # Tangle all vignettes now.

                cmd <- file.path(R.home("bin"), "Rscript")
                args <- c("--vanilla",
                          "--default-packages=", # some vignettes assume methods
                          "-e", shQuote("tools::buildVignettes(dir = '.', tangle = TRUE)"))
                ## since so many people use 'R CMD' in Makefiles,
                oPATH <- Sys.getenv("PATH")
                Sys.setenv(PATH = paste(R.home("bin"), oPATH,
                           sep = .Platform$path.sep))
                res <- system_with_capture(cmd, args)
                Sys.setenv(PATH = oPATH)
                if (res$status) {
                    resultLog(Log, "ERROR")
                    printLog0(Log, paste(c(res$stdout, ""),  collapse = "\n"))
                    do_exit(1L)
                } else {
                    # Rescan for weave and tangle output files
                    vigns <- pkgVignettes(dir = '.', output = TRUE, source = TRUE)
                    stopifnot(!is.null(vigns))

                    resultLog(Log, "OK")
                }

                ## We may need to install them.
                if (basename(vigns$dir) == "vignettes") {
                    ## inst may not yet exist
                    dir.create(doc_dir, recursive = TRUE, showWarnings = FALSE)
                    file.copy(c(vigns$docs, vigns$outputs, unlist(vigns$sources)), doc_dir)
                    unlink(c(vigns$outputs, unlist(vigns$sources)))
                    extras_file <- file.path("vignettes", ".install_extras")
                    if (file.exists(extras_file)) {
                        extras <- readLines(extras_file, warn = FALSE)
                        if(length(extras)) {
                            allfiles <- dir("vignettes", all.files = TRUE,
                                            full.names = TRUE, recursive = TRUE,
                                            include.dirs = TRUE)
                            inst <- rep(FALSE, length(allfiles))
                            for (e in extras)
                                inst <- inst | grepl(e, allfiles, perl = TRUE,
                                                     ignore.case = TRUE)
                            file.copy(allfiles[inst], doc_dir, recursive = TRUE)
                        }
                    }
                }

		vignetteIndex <- .build_vignette_index(vigns)

		if(NROW(vignetteIndex) > 0L) {
		    ## remove any files with no R code (they will have header comments).
		    ## if not correctly declared they might not be in the current encoding
		    sources <- vignetteIndex$R
		    for(i in seq_along(sources)) {
			file <- file.path(doc_dir, sources[i])
			if (!file_test("-f", file)) next
			bfr <- readLines(file, warn = FALSE)
			if(all(grepl("(^###|^[[:space:]]*$)", bfr, useBytes = TRUE))) {
			    unlink(file)
			    vignetteIndex$R[i] <- ""
			}
		    }
		}

		## Save the list
		dir.create("build", showWarnings = FALSE)
		saveRDS(vignetteIndex,
			file = file.path("build", "vignette.rds"))
            }
        } else {
            fv <- file.path("build", "vignette.rds")
            if(file.exists(fv)) {
                checkingLog(Log, "vignette meta-information")
                db <- readRDS(fv)
                pdfs <- file.path("inst", "doc", db[nzchar(db$PDF), ]$PDF)
                missing <- !file.exists(pdfs)
                if(any(missing)) {
                    msg <- c("Output(s) listed in 'build/vignette.rds' but not in package:",
                             strwrap(sQuote(pdfs[missing]), indent = 2L, exdent = 2L),
                             "Run R CMD build without --no-build-vignettes to re-create")
                    errorLog(Log, paste(msg, collapse = "\n"))
                    do_exit(1L)
                } else resultLog(Log, "OK")
            }
        }
        if (compact_vignettes != "no" &&
            length(pdfs <- dir(doc_dir, pattern = "[.]pdf", recursive = TRUE,
                               full.names = TRUE))) {
            messageLog(Log, "compacting vignettes and other PDF files")
            if(compact_vignettes %in% c("gs", "gs+qpdf", "both")) {
                gs_cmd <- find_gs_cmd()
                gs_quality <- "ebook"
            } else {
                gs_cmd <- ""
                gs_quality <- "none"
            }
            qpdf <-
                ifelse(compact_vignettes %in% c("qpdf", "gs+qpdf", "both"),
                       Sys.which(Sys.getenv("R_QPDF", "qpdf")), "")
            res <- compactPDF(pdfs, qpdf = qpdf,
                              gs_cmd = gs_cmd, gs_quality = gs_quality)
            res <- format(res, diff = 1e5)
            if(length(res))
                printLog0(Log, paste(" ", format(res), collapse = "\n"), "\n")
        }
        if (pkgInstalled) {
            unlink(libdir, recursive = TRUE)

	    ## And finally, clean up again.
            cleanup_pkg(pkgdir, Log)
        }
    }

    cleanup_pkg <- function(pkgdir, Log)
    {
        owd <- setwd(pkgdir); on.exit(setwd(owd))
        pkgname <- basename(pkgdir)
        if (dir.exists("src")) {
            setwd("src")
            messageLog(Log, "cleaning src")
            if (WINDOWS) {
                have_make <- nzchar(Sys.which(Sys.getenv("MAKE", "make")))
                if (file.exists("Makefile.win")) {
                    if (have_make)
                        Ssystem(Sys.getenv("MAKE", "make"), "-f Makefile.win clean")
                    else warning("unable to run 'make clean' in 'src'",
                                 domain = NA)
                } else {
                    if (file.exists("Makevars.win")) {
                        if (have_make) {
                            makefiles <- paste()
                            makefiles <- paste("-f",
                                               shQuote(file.path(R.home("share"), "make", "clean.mk")),
                                           "-f Makevars.win")
                            Ssystem(Sys.getenv("MAKE", "make"),
                                    c(makefiles, "clean"))
                        } else warning("unable to run 'make clean' in 'src'",
                                       domain = NA)
                    }
                    ## Also cleanup possible Unix leftovers ...
                    unlink(c(Sys.glob(c("*.o", "*.sl", "*.so", "*.dylib")),
                             paste0(pkgname, c(".a", ".dll", ".def")),
                             "symbols.rds"))
                    if (dir.exists(".libs")) unlink(".libs", recursive = TRUE)
                    if (dir.exists("_libs")) unlink("_libs", recursive = TRUE)
                }
            } else {
                makefiles <- paste("-f",
                                   shQuote(file.path(R.home("etc"),
                                                     Sys.getenv("R_ARCH"),
                                                     "Makeconf")))
                if (file.exists("Makefile")) {
                    makefiles <- paste(makefiles, "-f", "Makefile")
                    Ssystem(Sys.getenv("MAKE", "make"), c(makefiles, "clean"))
                } else {
                    if (file.exists("Makevars")) {
                        ## ensure we do have a 'clean' target.
                        makefiles <- paste(makefiles, "-f",
                                       shQuote(file.path(R.home("share"), "make", "clean.mk")),
                                           "-f Makevars")
                        Ssystem(Sys.getenv("MAKE", "make"),
                                c(makefiles, "clean"))
                    }
                    ## Also cleanup possible Windows leftovers ...
                    unlink(c(Sys.glob(c("*.o", "*.sl", "*.so", "*.dylib")),
                             paste0(pkgname, c(".a", ".dll", ".def")),
                             "symbols.rds"))
                    if (dir.exists(".libs")) unlink(".libs", recursive = TRUE)
                    if (dir.exists("_libs")) unlink("_libs", recursive = TRUE)
                }
            }
        }
        setwd(owd)
        ## It is not clear that we want to do this: INSTALL should do so.
        ## Also, certain environment variables should be set according
        ## to 'Writing R Extensions', but were not in Perl version (nor
        ## was cleanup.win used).
        if (WINDOWS) {
            if (file.exists("cleanup.win")) {
                ## check we have sh.exe first
                if (nzchar(Sys.which("sh.exe"))) {
                    Sys.setenv(R_PACKAGE_NAME = pkgname)
                    Sys.setenv(R_PACKAGE_DIR = pkgdir)
                    Sys.setenv(R_LIBRARY_DIR = dirname(pkgdir))
                    messageLog(Log, "running 'cleanup.win'")
                    Ssystem("sh", "./cleanup.win")
                }
            }
        } else if (file_test("-x", "cleanup")) {
            Sys.setenv(R_PACKAGE_NAME = pkgname)
            Sys.setenv(R_PACKAGE_DIR = pkgdir)
            Sys.setenv(R_LIBRARY_DIR = dirname(pkgdir))
            messageLog(Log, "running 'cleanup'")
            Ssystem("./cleanup")
        }
    }

    update_Rd_index <- function(oldindex, Rd_files, Log)
    {
        newindex <- tempfile()
        res <- try(Rdindex(Rd_files, newindex))
        if (inherits(res, "try-error")) {
            errorLog(Log, "computing Rd index failed")
            do_exit(1L)
        }
        checkingLog(Log, "whether ", sQuote(oldindex), " is up-to-date")
        if (file.exists(oldindex)) {
            ol <- readLines(oldindex, warn = FALSE) # e.g. BaM had missing final NL
            nl <- readLines(newindex)
            if (!identical(ol, nl)) {
                resultLog(Log, "NO")
               if (force) {
                    messageLog(Log, "removing ", sQuote(oldindex),
			      " as '--force' was given")
                    unlink(oldindex)
                } else {
                    messageLog(Log, "use '--force' to remove ",
			      "the existing ", sQuote(oldindex))
                    unlink(newindex)
                }
            } else {
                resultLog(Log, "OK")
                unlink(newindex)
            }
        } else {
            resultLog(Log, "NO")
            messageLog(Log, "creating new ", sQuote(oldindex))
            file.rename(newindex, oldindex)
        }
    }

    build_Rd_db <- function(pkgdir, libdir, desc) {
    	db <- .build_Rd_db(pkgdir, stages = NULL,
                           os = c("unix", "windows"), step = 1)
    	if (!length(db)) return(FALSE)

    	# Strip the pkgdir off the names
    	names(db) <- substring(names(db),
                               nchar(file.path(pkgdir, "man", "")) + 1L)

	containsSexprs <-
            which(sapply(db, function(Rd) getDynamicFlags(Rd)["\\Sexpr"]))
	if (!length(containsSexprs)) return(FALSE)

	messageLog(Log, "installing the package to process help pages")

        dir.create(libdir, mode = "0755", showWarnings = FALSE)
        savelib <- .libPaths()
        .libPaths(c(libdir, savelib))
        on.exit(.libPaths(savelib), add = TRUE)

        temp_install_pkg(pkgdir, libdir)

	containsBuildSexprs <-
            which(sapply(db, function(Rd) getDynamicFlags(Rd)["build"]))

	if (length(containsBuildSexprs)) {
	    for (i in containsBuildSexprs)
		db[[i]] <- prepare_Rd(db[[i]], stages = "build",
                                      stage2 = FALSE, stage3 = FALSE)
	    messageLog(Log, "saving partial Rd database")
	    partial <- db[containsBuildSexprs]
	    dir.create("build", showWarnings = FALSE)
	    saveRDS(partial, file.path("build", "partial.rdb"))
	}
	needRefman <- manual &&
            parse_description_field(desc, "BuildManual", TRUE) &&
            any(sapply(db, function(Rd) any(getDynamicFlags(Rd)[c("install", "render")])))
	if (needRefman) {
	    messageLog(Log, "building the PDF package manual")
	    dir.create("build", showWarnings = FALSE)
	    refman <- file.path(pkgdir, "build",
                                paste0(basename(pkgdir), ".pdf"))
	    ..Rd2pdf(c("--force", "--no-preview",
	               paste0("--output=", refman),
	               pkgdir), quit = FALSE)
        }
	return(TRUE)
    }

    ## also fixes up missing final NL
    fix_nonLF_in_files <- function(pkgname, dirPattern, Log)
    {
	if(dir.exists(sDir <- file.path(pkgname, "src"))) {
            files <- dir(sDir, pattern = dirPattern,
                         full.names = TRUE, recursive = TRUE)
            ## FIXME: This "destroys" all timestamps
            for (ff in files) {
                lines <- readLines(ff, warn = FALSE)
                writeLinesNL(lines, ff)
            }
        }
    }

    fix_nonLF_in_source_files <- function(pkgname, Log) {
        fix_nonLF_in_files(pkgname, dirPattern = "\\.([cfh]|cc|cpp)$", Log)
    }
    fix_nonLF_in_make_files <- function(pkgname, Log) {
        fix_nonLF_in_files(pkgname,
                           paste0("^",c("Makefile", "Makefile.in", "Makefile.win",
                                       "Makevars", "Makevars.in", "Makevars.win"),
                                 "$"), Log)
    }

    find_empty_dirs <- function(d)
    {
        ## dir(recursive = TRUE) did not include directories, so
        ## we needed to do this recursively
        files <- dir(d, all.files = TRUE, full.names = TRUE)
        isdir <- file.info(files)$isdir
        for (dd in files[isdir]) {
            if (grepl("/\\.+$", dd)) next
            find_empty_dirs(dd)
        }
        ## allow per-package override
        keep_empty1 <- parse_description_field(desc, "BuildKeepEmpty",
                                               keep_empty)
        if (!keep_empty1) # might have removed a dir
            files <- dir(d, all.files = TRUE, full.names = TRUE)
        if (length(files) <= 2L) { # always has ., ..
            if (keep_empty1) {
                printLog(Log, "WARNING: directory ", sQuote(d), " is empty\n")
            } else {
                unlink(d, recursive = TRUE)
                printLog(Log, "Removed empty directory ", sQuote(d), "\n")
            }
        }
    }

    fixup_R_dep <- function(pkgname, ver = "2.10")
    {
        desc <- .read_description(file.path(pkgname, "DESCRIPTION"))
        Rdeps <- .split_description(desc)$Rdepends2
        for(dep in Rdeps) {
            if(dep$op != '>=') next
            if(dep$version >= package_version(ver)) return()
        }

        on.exit(Sys.setlocale("LC_CTYPE", Sys.getlocale("LC_CTYPE")))
        Sys.setlocale("LC_CTYPE", "C")

        flatten <- function(x) {
            if(length(x) == 3L)
                paste0(x$name, " (", x$op, " ", x$version, ")")
            else x[[1L]]
        }
        deps <- desc["Depends"]
        desc["Depends"] <- if(!is.na(deps)) {
            deps <- .split_dependencies(deps)
            deps <- deps[names(deps) != "R"] # could be more than one
            paste(c(sprintf("R (>= %s)", ver), sapply(deps, flatten)),
                  collapse = ", ")
        } else sprintf("R (>= %s)", ver)

        .write_description(desc, file.path(pkgname, "DESCRIPTION"))

        printLog(Log,
                 "  NB: this package now depends on R (>= ", ver, ")\n")
    }

    resave_data_rda <- function(pkgname, resave_data)
    {
        if (resave_data == "no") return()
        ddir <- file.path(pkgname, "data")
        if(resave_data == "best") {
            files <- Sys.glob(c(file.path(ddir, "*.rda"),
                                file.path(ddir, "*.RData"),
                                file.path(pkgname, "R", "sysdata.rda")))
            messageLog(Log, "re-saving image files")
            resaveRdaFiles(files)
            rdas <- checkRdaFiles(files)
            if(any(rdas$compress %in% c("bzip2", "xz")))
                fixup_R_dep(pkgname, "2.10")
        } else {
            ## ddir need not exist if just R/sysdata.rda
            rdas <- checkRdaFiles(Sys.glob(c(file.path(ddir, "*.rda"),
                                             file.path(ddir, "*.RData"))))
            if(nrow(rdas)) {
                update <- with(rdas, ASCII | compress == "none" | version < 2)
                if(any(update)) {
                    messageLog(Log, "re-saving image files")
                    resaveRdaFiles(row.names(rdas)[update], "gzip")
                }
            }
            if(file.exists(f <- file.path(pkgname, "R", "sysdata.rda"))) {
                rdas <- checkRdaFiles(f)
                update <- with(rdas, ASCII | compress == "none" | version < 2)
                if(any(update)) {
                    messageLog(Log, "re-saving sysdata.rda")
                    resaveRdaFiles(f, "gzip")
                }
            }
        }
    }


    resave_data_others <- function(pkgname, resave_data)
    {
        if (resave_data == "no") return()
        ddir <- file.path(pkgname, "data")
        dataFiles <- grep("\\.(rda|RData)$",
                          list_files_with_type(ddir, "data"),
                          invert = TRUE, value = TRUE)
        if (!length(dataFiles)) return()
        Rs <- grep("\\.[Rr]$", dataFiles, value = TRUE)
        if (length(Rs)) { # these might use .txt etc
            messageLog(Log, "re-saving .R files as .rda")
            ## ensure utils is visible
            library("utils")
            lapply(Rs, function(x){
                envir <- new.env(hash = TRUE)
                sys.source(x, chdir = TRUE, envir = envir)
                save(list = ls(envir, all.names = TRUE),
                     file = sub("\\.[Rr]$", ".rda", x),
                     compress = TRUE, compression_level = 9,
                     envir = envir)
                unlink(x)
            })
            printLog(Log,
                     "  NB: *.R converted to .rda: other files may need to be removed\n")
        }
        tabs <- grep("\\.(CSV|csv|TXT|tab|txt)$", dataFiles, value = TRUE)
        if (length(tabs)) {
            messageLog(Log, "re-saving tabular files")
            if (resave_data == "gzip") {
                lapply(tabs, function(nm) {
                    ## DiceDesign/data/greenwood.table.txt is missing NL
                    x <- readLines(nm, warn = FALSE)
                    con <- gzfile(paste(nm, "gz", sep = "."), "wb")
                    writeLines(x, con)
                    close(con)
                    unlink(nm)
                })
            } else {
                OK <- TRUE
                lapply(tabs, function(nm) {
                    x <- readLines(nm, warn = FALSE)
                    nm3 <- paste(nm, c("gz", "bz2", "xz"), sep = ".")
                    con <- gzfile(nm3[1L], "wb", compression = 9L); writeLines(x, con); close(con)
                    con <- bzfile(nm3[2L], "wb", compression = 9L); writeLines(x, con); close(con)
                    con <- xzfile(nm3[3L], "wb", compression = 9L); writeLines(x, con); close(con)
                    sizes <- file.info(nm3)$size * c(0.9, 1, 1)
                    ind <- which.min(sizes)
                    if(ind > 1) OK <<- FALSE
                    unlink(c(nm, nm3[-ind]))
                })
                if (!OK) fixup_R_dep(pkgname, "2.10")
            }
        }
    }

    force <- FALSE
    vignettes <- TRUE
    manual <- TRUE  # Install the manual if Rds contain \Sexprs
    with_md5 <- FALSE
    INSTALL_opts <- character()
    pkgs <- character()
    options(showErrorCalls = FALSE, warn = 1)

    ## Read in build environment file.
    Renv <- Sys.getenv("R_BUILD_ENVIRON", unset = NA)
    if(!is.na(Renv)) {
        ## Do not read any build environment file if R_BUILD_ENVIRON is
        ## set to empty of something non-existent.
        if(nzchar(Renv) && file.exists(Renv)) readRenviron(Renv)
    } else {
        ## Read in ~/.R/build.Renviron[.rarch] (if existent).
        rarch <- .Platform$r_arch
        if (nzchar(rarch) &&
            file.exists(Renv <- paste("~/.R/build.Renviron", rarch, sep = ".")))
            readRenviron(Renv)
        else if (file.exists(Renv <- "~/.R/build.Renviron"))
            readRenviron(Renv)
    }

    ## Configurable variables.
    compact_vignettes <- Sys.getenv("_R_BUILD_COMPACT_VIGNETTES_", "no")
    resave_data <- Sys.getenv("_R_BUILD_RESAVE_DATA_", "gzip")

    keep_empty <-
        config_val_to_logical(Sys.getenv("_R_BUILD_KEEP_EMPTY_DIRS_", "FALSE"))

    if (is.null(args)) {
        args <- commandArgs(TRUE)
        ## it seems that splits on spaces, so try harder.
        args <- paste(args, collapse = " ")
        args <- strsplit(args,'nextArg', fixed = TRUE)[[1L]][-1L]
    }

    while(length(args)) {
        a <- args[1L]
        if (a %in% c("-h", "--help")) {
            Usage()
            do_exit(0L)
        }
        else if (a %in% c("-v", "--version")) {
            cat("R add-on package builder: ",
                R.version[["major"]], ".",  R.version[["minor"]],
                " (r", R.version[["svn rev"]], ")\n", sep = "")
            cat("",
                "Copyright (C) 1997-2013 The R Core Team.",
                "This is free software; see the GNU General Public License version 2",
                "or later for copying conditions.  There is NO warranty.",
                sep = "\n")
            do_exit(0L)
        } else if (a == "--force") {
            force <- TRUE
        } else if (a == "--keep-empty-dirs") {
            keep_empty <- TRUE
        } else if (a == "--no-build-vignettes") {
            vignettes <- FALSE
        } else if (a == "--no-vignettes") { # pre-3.0.0 version
            stop("'--no-vignettes' is defunct:\n  use '--no-build-vignettes' instead",
                 call. = FALSE, domain = NA)
        } else if (a == "--resave-data") {
            resave_data <- "best"
        } else if (a == "--no-resave-data") {
            resave_data <- "no"
        } else if (substr(a, 1, 14) == "--resave-data=") {
            resave_data <- substr(a, 15, 1000)
        } else if (a == "--no-manual") {
            manual <- FALSE
        } else if (substr(a, 1, 20) == "--compact-vignettes=") {
            compact_vignettes <- substr(a, 21, 1000)
        } else if (a == "--compact-vignettes") {
            compact_vignettes <- "qpdf"
        } else if (a == "--md5") {
            with_md5 <- TRUE
        } else if (substr(a, 1, 1) == "-") {
            message("Warning: unknown option ", sQuote(a))
        } else pkgs <- c(pkgs, a)
        args <- args[-1L]
    }

    if(!compact_vignettes %in% c("no", "qpdf", "gs", "gs+qpdf", "both")) {
        warning(gettextf("invalid value for '--compact-vignettes', assuming %s",
                         "\"qpdf\""),
                domain = NA)
        compact_vignettes <-"qpdf"
    }

    Sys.unsetenv("R_DEFAULT_PACKAGES")

    startdir <- getwd()
    if (is.null(startdir))
        stop("current working directory cannot be ascertained")
    R_platform <- Sys.getenv("R_PLATFORM", "unknown-binary")
    libdir <- tempfile("Rinst")

    if (WINDOWS) {
        ## Some people have *assumed* that R_HOME uses / in Makefiles
        ## Spaces in paths might still cause trouble.
        rhome <- chartr("\\", "/", R.home())
        Sys.setenv(R_HOME = rhome)
    }

    for(pkg in pkgs) {
        Log <- newLog() # if not stdin; on.exit(closeLog(Log))
        ## remove any trailing /, for Windows' sake
        pkg <- sub("/$", "", pkg)
        ## '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.'
        setwd(startdir)
	res <- tryCatch(setwd(pkg), error = function(e)e)
	if (inherits(res, "error")) {
            errorLog(Log, "cannot change to directory ", sQuote(pkg))
            do_exit(1L)
        }
        pkgdir <- getwd()
        pkgname <- basename(pkgdir)
        checkingLog(Log, "for file ", sQuote(file.path(pkg, "DESCRIPTION")))
        f <- file.path(pkgdir, "DESCRIPTION")
        if (file.exists(f)) {
            desc <- try(.read_description(f))
            if (inherits(desc, "try-error") || !length(desc)) {
                resultLog(Log, "EXISTS but not correct format")
                do_exit(1L)
            }
            resultLog(Log, "OK")
        } else {
            resultLog(Log, "NO")
            do_exit(1L)
        }
        intname <- desc["Package"]
        ## make a copy, cd to parent of copy
        setwd(dirname(pkgdir))
        filename <- paste0(intname, "_", desc["Version"], ".tar")
        filepath <- file.path(startdir, filename)
        Tdir <- tempfile("Rbuild")
        dir.create(Tdir, mode = "0755")
        if (WINDOWS) {
            ## This preserves read-only for files, but not dates
            if (!file.copy(pkgname, Tdir, recursive = TRUE)) {
                errorLog(Log, "copying to build directory failed")
                do_exit(1L)
            }
        } else {
            ## This should preserve dates and permissions (subject to
            ## umask, if that is consulted which it seems it usually is not).
            ## Permissions are increased later.
	    cp_sw <- if(Sys.info()[["sysname"]] == "Linux") ## << need GNU cp
		## unfortunately, '-pr' does not dereference sym.links
		"-Lr --preserve=timestamps" else "-pr"
            if (system(paste("cp", cp_sw, shQuote(pkgname), shQuote(Tdir)))) {
                errorLog(Log, "copying to build directory failed")
                do_exit(1L)
            }
        }
        setwd(Tdir)

        ## Now correct the package name (PR#9266)
        if (pkgname != intname) {
            if (!file.rename(pkgname, intname)) {
                message(gettextf("Error: cannot rename directory to %s",
                                 sQuote(intname)), domain = NA)
                do_exit(1L)
            }
            pkgname <- intname
        }

        ## prepare the copy
        messageLog(Log, "preparing ", sQuote(pkgname), ":")
        prepare_pkg(normalizePath(pkgname, "/"), desc, Log);
        owd <- setwd(pkgname)
        ## remove exclude files
        allfiles <- dir(".", all.files = TRUE, recursive = TRUE,
                        full.names = TRUE, include.dirs = TRUE)
        allfiles <- substring(allfiles, 3L)  # drop './'
        bases <- basename(allfiles)
        exclude <- rep(FALSE, length(allfiles))
        ignore <- get_exclude_patterns()
        ## handle .Rbuildignore:
        ## 'These patterns should be Perl regexps, one per line,
        ##  to be matched against the file names relative to
        ##  the top-level source directory.'
        ignore_file <- file.path(pkgdir, ".Rbuildignore")
        if (file.exists(ignore_file))
            ignore <- c(ignore, readLines(ignore_file, warn = FALSE))
        for(e in ignore[nzchar(ignore)])
            exclude <- exclude | grepl(e, allfiles, perl = TRUE,
                                       ignore.case = TRUE)

        isdir <- file_test("-d", allfiles)
        ## old (pre-2.10.0) dirnames
        exclude <- exclude | (isdir & (bases %in%
                                       c("check", "chm", .vc_dir_names)))
        exclude <- exclude | (isdir & grepl("([Oo]ld|\\.Rcheck)$", bases))
        ## FIXME: GNU make uses GNUmakefile (note capitalization)
        exclude <- exclude | bases %in% c("Read-and-delete-me", "GNUMakefile")
        ## Mac resource forks
        exclude <- exclude | grepl("^\\._", bases)
        exclude <- exclude | (isdir & grepl("^src.*/[.]deps$", allfiles))
	## Windows DLL resource file
        exclude <- exclude | (allfiles == paste0("src/", pkgname, "_res.rc"))
        ## inst/doc/.Rinstignore is a mistake
        exclude <- exclude | grepl("inst/doc/[.](Rinstignore|build[.]timestamp)$", allfiles)
        exclude <- exclude | grepl("vignettes/[.]Rinstignore$", allfiles)
        ## leftovers
        exclude <- exclude | grepl("^.Rbuildindex[.]", allfiles)
        exclude <- exclude | (bases %in% .hidden_file_exclusions)
        unlink(allfiles[exclude], recursive = TRUE, force = TRUE)
        setwd(owd)

        ## Fix up man, R, demo inst/doc directories
        res <- .check_package_subdirs(pkgname, TRUE)
        if (any(sapply(res, length))) {
            messageLog(Log, "excluding invalid files")
            print(res) # FIXME print to Log?
        }
        setwd(Tdir)
        ## Fix permissions for all files to be at least 644, and dirs 755
        ## Not restricted by umask.
	if (!WINDOWS) .Call(dirchmod, pkgname, group.writable=FALSE)
        ## Add build stamp to the DESCRIPTION file.
        add_build_stamp_to_description_file(file.path(pkgname,
                                                      "DESCRIPTION"))
        ## Add expanded R fields to the DESCRIPTION file.
        add_expanded_R_fields_to_description_file(file.path(pkgname,
                                                            "DESCRIPTION"))
        messageLog(Log,
                   "checking for LF line-endings in source and make files")
        fix_nonLF_in_source_files(pkgname, Log)
        fix_nonLF_in_make_files(pkgname, Log)
        messageLog(Log, "checking for empty or unneeded directories");
        find_empty_dirs(pkgname)
        for(dir in c("Meta", "R-ex", "chtml", "help", "html", "latex")) {
            d <- file.path(pkgname, dir)
            if (dir.exists(d)) {
                msg <- paste("WARNING: Removing directory",
                             sQuote(d),
                             "which should only occur",
                             "in an installed package")
                printLog(Log, paste(strwrap(msg, indent = 0L, exdent = 2L),
                                    collapse = "\n"), "\n")
                unlink(d, recursive = TRUE)
            }
        }
        ## remove subarch build directories
        unlink(file.path(pkgname,
                         c("src-i386", "src-x64", "src-x86_64", "src-ppc")),
               recursive = TRUE)

        ## work on 'data' directory if present
        if(file_test("-d", file.path(pkgname, "data")) ||
           file_test("-f", file.path(pkgname, "R", "sysdata.rda"))) {
            messageLog(Log, "looking to see if a 'data/datalist' file should be added")
            ## in some cases data() needs the package installed as
            ## there are links to the package's namespace
            tryCatch(add_datalist(pkgname),
                     error = function(e)
                     printLog(Log, "  unable to create a 'datalist' file: may need the package to be installed\n"))
            ## allow per-package override
            resave_data1 <- parse_description_field(desc, "BuildResaveData",
                                                    resave_data, FALSE)
            resave_data_others(pkgname, resave_data1)
            resave_data_rda(pkgname, resave_data1)
        }

	## add NAMESPACE if the author didn't write one
	if(!file.exists(namespace <- file.path(pkgname, "NAMESPACE")) ) {
	    messageLog(Log, "creating default NAMESPACE file")
	    writeDefaultNamespace(namespace)
	}

        if(with_md5) {
	    messageLog(Log, "adding MD5 file")
            .installMD5sums(pkgname)
        } else {
            ## remove any stale file
            unlink(file.path(pkgname, "MD5"))
        }

        ## Finalize
        filename <- paste0(pkgname, "_", desc["Version"], ".tar.gz")
        filepath <- file.path(startdir, filename)
        ## NB: tests/reg-packages.R relies on this exact format!
        messageLog(Log, "building ", sQuote(filename))
        res <- utils::tar(filepath, pkgname, compression = "gzip",
                          compression_level = 9L,
                          tar = Sys.getenv("R_BUILD_TAR"),
                          extra_flags = NULL) # use trapdoor
        if (res) {
            errorLog(Log, "packaging into .tar.gz failed")
            do_exit(1L)
        }
        message("") # blank line

        setwd(startdir)
        unlink(Tdir, recursive = TRUE)
        on.exit() # cancel closeLog
        closeLog(Log)
    }
    do_exit(0L)
}
#  File src/library/tools/R/check.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2014 The R Core Team
#
# NB: also copyright date in Usage.
#
#  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 of the License, 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/

###- R based engine for R CMD check

## R developers can use this to debug the function by running it
## directly as tools:::.check_packages(args), where the args should
## be what commandArgs(TRUE) would return, that is a character vector
## of (space-delimited) terms that would be passed to R CMD checks.

## Used for INSTALL and Rd2pdf
run_Rcmd <- function(args, out = "", env = "")
{
    if(.Platform$OS.type == "windows")
        system2(file.path(R.home("bin"), "Rcmd.exe"), args, out, out)
    else
        system2(file.path(R.home("bin"), "R"), c("CMD", args), out, out,
                env = env)
}

R_runR <- function(cmd = NULL, Ropts = "", env = "",
                   stdout = TRUE, stderr = TRUE, stdin = NULL,
                   arch = "")
{
    if (.Platform$OS.type == "windows") {
        ## workaround Windows problem with input = cmd
        if (!is.null(cmd)) {
            ## In principle this should escape \
           Rin <- tempfile("Rin"); on.exit(unlink(Rin)); writeLines(cmd, Rin)
        } else Rin <- stdin
        suppressWarnings(system2(if(nzchar(arch)) file.path(R.home(), "bin", arch, "Rterm.exe")
                                 else file.path(R.home("bin"), "Rterm.exe"),
                                 c(Ropts, paste("-f", Rin)), stdout, stderr, env = env))
    } else {
        suppressWarnings(system2(file.path(R.home("bin"), "R"),
                                 c(if(nzchar(arch)) paste0("--arch=", arch), Ropts),
                                 stdout, stderr, stdin, input = cmd, env = env))
    }
}

setRlibs <-
    function(lib0 = "", pkgdir = ".", suggests = FALSE, libdir = NULL,
             self = FALSE, self2 = TRUE, quote = FALSE, LinkingTo = FALSE)
{
    WINDOWS <- .Platform$OS.type == "windows"
    useJunctions <- WINDOWS && !nzchar(Sys.getenv("R_WIN_NO_JUNCTIONS"))
    flink <- function(from, to) {
        res <- if(WINDOWS) {
            if(useJunctions) Sys.junction(from, to)
            else file.copy(from, to, recursive = TRUE)
        } else file.symlink(from, to)
        if (!res) stop(gettextf("cannot link from %s", from), domain = NA)
    }

    pi <- .split_description(.read_description(file.path(pkgdir, "DESCRIPTION")))
    thispkg <- unname(pi$DESCRIPTION["Package"])

    ## We need to make some assumptions about layout: this version
    ## assumes .Library contains standard and recommended packages
    ## and nothing else.
    tmplib <- tempfile("RLIBS_")
    dir.create(tmplib)
    ## Since this is under the session directory and only contains
    ## symlinks and dummies (hence will be small) we never clean it up.

    test_recommended <-
        config_val_to_logical(Sys.getenv("_R_CHECK_NO_RECOMMENDED_", "FALSE"))

    if(test_recommended) {
        ## Now add dummies for recommended packages (removed later if declared)
        recommended <-  .get_standard_package_names()$recommended
        ## grDevices has :: to KernSmooth
        ## stats has ::: to Matrix, Matrix depends on lattice
        ## which gives false positives in MASS and Rcpp
        ## codetools is really part of tools
        exceptions <- "codetools"
        if (thispkg %in% c("MASS", "Rcpp"))
            exceptions <- c(exceptions, "Matrix", "lattice")
        if (thispkg %in%
            c("Modalclust", "aroma.core", "iWebPlots",
              "openair", "oce", "pcalg", "tileHMM"))
            exceptions <- c(exceptions, "KernSmooth")
        recommended <- recommended[!recommended %in% exceptions]
        for(pkg in recommended) {
            if(pkg == thispkg) next
            dir.create(pd <- file.path(tmplib, pkg))
            file.copy(file.path(.Library, pkg, "DESCRIPTION"), pd)
            ## to make sure find.package throws an error:
            close(file(file.path(pd, "dummy_for_check"), "w"))
        }
    }

    deps <- unique(c(names(pi$Depends), names(pi$Imports),
                     if(LinkingTo) names(pi$LinkingTo),
                     if(suggests) names(pi$Suggests)))
    if(length(libdir) && self2) flink(file.path(libdir, thispkg), tmplib)
    ## .Library is not necessarily canonical, but the .libPaths version is.
    lp <- .libPaths()
    poss <- c(lp[length(lp)], .Library)
    already <- thispkg
    more <- unique(deps[!deps %in% already]) # should not depend on itself ...
    while(length(more)) {
        m0 <- more; more <- character()
        for (pkg in m0) {
            if (test_recommended) {
                if (pkg %in% recommended) unlink(file.path(tmplib, pkg), TRUE)
                ## hard-code dependencies for now.
                if (pkg == "mgcv")
                    unlink(file.path(tmplib, c("Matrix", "lattice", "nlme")), TRUE)
                if (pkg == "Matrix") unlink(file.path(tmplib, "lattice"), TRUE)
                if (pkg == "class") unlink(file.path(tmplib, "MASS"), TRUE)
                if (pkg == "nlme") unlink(file.path(tmplib, "lattice"), TRUE)
            }
            where <- find.package(pkg, quiet = TRUE)
            if(length(where)) {
                if (!(dirname(where) %in% poss))
                    flink(where, tmplib)
                else if (!test_recommended)
                    # If the package is in the standard library we can
                    # assume dependencies have been met, but we can
                    # only skip the traversal if we aren't testing recommended
                    # packages, because loading will fail if there is
                    # an indirect dependency to one that has been hidden
                    # by a dummy in tmplib.
                    next
                pi <- readRDS(file.path(where, "Meta", "package.rds"))
                more <- c(more, names(pi$Depends), names(pi$Imports),
                          names(pi$LinkingTo))
            }
        }
        already <- c(already, m0)
        more <- unique(more[!more %in% already])
    }
    if (self) flink(normalizePath(pkgdir), tmplib)
    # print(dir(tmplib))
    rlibs <- tmplib
    if (nzchar(lib0)) rlibs <- c(lib0, rlibs)
    rlibs <- paste(rlibs, collapse = .Platform$path.sep)
    if(quote) rlibs <- shQuote(rlibs)
    c(paste("R_LIBS", rlibs, sep = "="),
      if(WINDOWS) " R_ENVIRON_USER='no_such_file'" else "R_ENVIRON_USER=''",
      if(WINDOWS) " R_LIBS_USER='no_such_dir'" else "R_LIBS_USER=''",
      " R_LIBS_SITE='no_such_dir'")
}

###- The main function for "R CMD check"  {currently extends all the way to the end-of-file}
.check_packages <- function(args = NULL)
{
    WINDOWS <- .Platform$OS.type == "windows"
    ## this requires on Windows: file.exe (optional)

    wrapLog <- function(...) {
        text <- paste(..., collapse = " ")
        ## strwrap expects paras separated by blank lines.
        ## Perl's wrap split on \n
        text <- strsplit(text, "\n", useBytes = TRUE)[[1L]]
        printLog(Log, paste(strwrap(text), collapse = "\n"), "\n")
    }

    ## Used for
    ## .check_packages_used
    ## .check_packages_used_in_examples
    ## .check_packages_used_in_tests
    ## .check_packages_used_in_vignettes
    ## checkS3methods
    ## checkReplaceFuns
    ## checkFF
    ## .check_code_usage_in_package (with full set)
    ## .check_T_and_F (with full set)
    ## .check_dotInternal (with full set)
    ## undoc, codoc, codocData, codocClasses
    ## checkDocFiles, checkDocStyle
    ## The default set of packages here are as they are because
    ## .get_S3_generics_as_seen_from_package needs utils,graphics,stats
    ##  Used by checkDocStyle (which needs the generic visible) and checkS3methods.
    R_runR2 <-
        if(WINDOWS) {
            function(cmd,
                     env = "R_DEFAULT_PACKAGES=utils,grDevices,graphics,stats")
                {
                    out <- R_runR(cmd, R_opts2, env)
                    ## pesky gdata ....
                    grep("^(ftype: not found|File type)", out,
                         invert = TRUE, value = TRUE)
                }
        } else
            function(cmd,
                     env = "R_DEFAULT_PACKAGES='utils,grDevices,graphics,stats'")
            {
                out <- R_runR(cmd, R_opts2, env)
                if (R_check_suppress_RandR_message)
                    grep('^Xlib: *extension "RANDR" missing on display', out,
                         invert = TRUE, value = TRUE)
                else out
            }

    dir.exists <- function(x) !is.na(isdir <- file.info(x)$isdir) & isdir

    td0 <- Inf # updated below
    print_time <- function(t1, t2, Log)
    {
        td <- t2 - t1
        if(td[3L] < td0) return()
        td2 <- if (td[3L] > 600) {
            td <- td/60
            if(WINDOWS) sprintf(" [%dm]", round(td[3L]))
            else sprintf(" [%dm/%dm]", round(sum(td[-3L])), round(td[3L]))
        } else {
            if(WINDOWS) sprintf(" [%ds]", round(td[3L]))
            else sprintf(" [%ds/%ds]", round(sum(td[-3L])), round(td[3L]))
        }
        cat(td2)
        if (!is.null(Log) && Log$con > 0L) cat(td2, file = Log$con)
    }

    parse_description_field <- function(desc, field, default=TRUE)
    {
        tmp <- desc[field]
        if (is.na(tmp)) default
        else switch(tmp,
                    "yes"=, "Yes" =, "true" =, "True" =, "TRUE" = TRUE,
                    "no" =, "No" =, "false" =, "False" =, "FALSE" = FALSE,
                    default)
    }

    check_pkg <- function(pkg, pkgname, pkgoutdir, startdir, libdir, desc,
                          is_base_pkg, is_rec_pkg, subdirs, extra_arch)
    {
        ## pkg is the argument we received from the main loop.
        ## pkgdir is the corresponding absolute path,

        checkingLog(Log, "package directory")
        setwd(startdir)
        pkg <- sub("/$", "", pkg)
        if (dir.exists(pkg)) {
            setwd(pkg) ## wrap in try()?
            pkgdir <- getwd()
            resultLog(Log, "OK")
        } else {
            errorLog(Log, "Package directory ", sQuote(pkg), "does not exist.")
            do_exit(1L)
        }

        haveR <- dir.exists("R") && !extra_arch

        if (!extra_arch) {
            if(dir.exists("build")) check_build()
            check_meta()  # Check DESCRIPTION meta-information.
            check_top_level()
            check_detritus()
            check_indices()
            check_subdirectories(haveR, subdirs)
            ## Check R code for non-ASCII chars which
            ## might be syntax errors in some locales.
            if (!is_base_pkg && haveR && R_check_ascii_code) check_non_ASCII()
        } # end of !extra_arch

        ## Check we can actually load the package: base is always loaded
        if (do_install && pkgname != "base") {
            if (this_multiarch) {
                Log$stars <<-  "**"
                for (arch in inst_archs) {
                    printLog(Log, "* loading checks for arch ", sQuote(arch), "\n")
                    check_loading(arch)
                }
                Log$stars <<-  "*"
            } else {
                check_loading()
            }
        }

        if (haveR) {
            check_R_code() # unstated dependencies, S3 methods, replacement, foreign
            check_R_files(is_rec_pkg) # codetools etc
        }

        check_Rd_files(haveR)

        check_data() # 'data' dir and sysdata.rda

        if (!is_base_pkg && dir.exists("src") && !extra_arch) check_src_dir()

        if(do_install &&
           dir.exists("src") &&
           length(so_symbol_names_table)) # suitable OS
            check_sos()

        miss <- file.path("inst", "doc", c("Rplots.ps", "Rplots.pdf"))
        if (any(f <- file.exists(miss))) {
            checkingLog(Log, "for left-overs from vignette generation")
            warningLog(Log)
            printLog(Log,
                     paste("  file", paste(sQuote(miss[f]), collapse = ", "),
                           "will not be installed: please remove it\n"))
        }
        if (dir.exists("inst/doc")) {
            if (R_check_doc_sizes) check_doc_size()
            else if (as_cran)
                warningLog(Log, "'qpdf' is needed for checks on size reduction of PDFs")
        }
        if (dir.exists("inst/doc") && do_install) check_doc_contents()
        if (dir.exists("vignettes")) check_vign_contents()
        if (dir.exists("inst/doc") && !dir.exists("vignettes")) {
            pattern <- vignetteEngine("Sweave")$pattern
            sources <- setdiff(list.files(file.path("inst", "doc"),
                                          pattern = pattern),
                               list.files("vignettes", pattern = pattern))
            buildPkgs <- .get_package_metadata(".")["VignetteBuilder"]
            if (!is.na(buildPkgs)) {
                buildPkgs <- unlist(strsplit(buildPkgs, ","))
                buildPkgs <- unique(gsub('[[:space:]]', '', buildPkgs))
                engineList <- vignetteEngine(package = buildPkgs)
                for(nm in names(engineList)) {
                    pattern <- engineList[[nm]]$pattern
                    sources <- c(sources,
                                 setdiff(list.files(file.path("inst", "doc"),
                                                    pattern = pattern),
                                         list.files("vignettes", pattern = pattern)))
                }
            }
            sources <- unique(sources)
            if(length(sources)) {
                checkingLog(Log, "for old-style vignette sources")
                msg <- c("Vignette sources only in 'inst/doc':",
                         strwrap(paste(sQuote(sources), collapse = ", "),
                                 indent = 2L, exdent = 2L),
                         "A 'vignettes' directory is required as from R 3.1.0",
                         "and these will not be indexed nor checked")
                ## warning or error eventually
                noteLog(Log, paste(msg, collapse = "\n"))
            }
        }

        setwd(pkgoutdir)

        ## Run the examples: this will be skipped if installation was
        if (dir.exists(file.path(libdir, pkgname, "help"))) {
            run_examples()
        } else if (dir.exists(file.path(pkgdir, "man"))) {
            checkingLog(Log, "examples")
            resultLog(Log, "SKIPPED")
        }

        ## Run the package-specific tests.
        tests_dir <- file.path(pkgdir, "tests")
        if (dir.exists(tests_dir) && # trackObjs has only *.Rin
            length(dir(tests_dir, pattern = "\\.(R|Rin)$")))
            run_tests()

        ## Check package vignettes.
        setwd(pkgoutdir)
        run_vignettes(desc)

    } ## end{ check_pkg }

    check_file_names <- function()
    {
        ## Check for portable file names.
        checkingLog(Log, "for portable file names")

        ## Build list of exclude patterns.
        ignore <- get_exclude_patterns()
        ignore_file <- ".Rbuildignore"
        if (ignore_file %in% dir())
            ignore <- c(ignore, readLines(ignore_file))

        ## Ensure that the names of the files in the package are valid
        ## for at least the supported OS types.  Under Unix, we
        ## definitely cannot have '/'.  Under Windows, the control
        ## characters as well as " * : < > ? \ | (i.e., ASCII
        ## characters 1 to 31 and 34, 36, 58, 60, 62, 63, 92, and 124)
        ## are or can be invalid.  (In addition, one cannot have
        ## one-character file names consisting of just ' ', '.', or
        ## '~'., and '~' has a special meaning for 8.3 short file
        ## names).

        ## Based on information by Uwe Ligges, Duncan Murdoch, and
        ## Brian Ripley: see also
        ## http://msdn.microsoft.com/en-us/library/aa365247%28VS.85%29.aspx

        ## In addition, Windows does not allow the following DOS type
        ## device names (by themselves or with possible extensions),
        ## see e.g.
        ## http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp
        ## http://msdn.microsoft.com/en-us/library/aa365247%28VS.85%29.aspx#naming_conventions
        ## and http://en.wikipedia.org/wiki/Filename (which as of
        ## 2007-04-22 is wrong about claiming that COM0 and LPT0 are
        ## disallowed):
        ##
        ## CON: Keyboard and display
        ## PRN: System list device, usually a parallel port
        ## AUX: Auxiliary device, usually a serial port
        ## NUL: Bit-bucket device
        ## CLOCK$: System real-time clock
        ## COM1, COM2, COM3, COM4, COM5, COM6, COM7, COM8, COM9:
        ##   Serial communications ports 1-9
        ## LPT1, LPT2, LPT3, LPT4, LPT5, LPT6, LPT7, LPT8, LPT9:
        ##   parallel printer ports 1-9

        ## In addition, the names of help files get converted to HTML
        ## file names and so should be valid in URLs.  We check that
        ## they are ASCII and do not contain %, which is what is known
        ## to cause troubles.

        allfiles <- dir(".", all.files = TRUE,
                        full.names = TRUE, recursive = TRUE)
        allfiles <- c(allfiles, unique(dirname(allfiles)))
        allfiles <- af <- sub("^./", "", allfiles)
        ignore_re <- paste0("(", paste(ignore, collapse = "|"), ")")
        allfiles <- grep(ignore_re, allfiles, invert = TRUE, value = TRUE)

        bad_files <- allfiles[grepl("[[:cntrl:]\"*/:<>?\\|]",
                                    basename(allfiles))]
        is_man <- grepl("man$", dirname(allfiles))
        bad <- sapply(strsplit(basename(allfiles[is_man]), ""),
                      function(x) any(grepl("[^ -~]|%", x)))
        if (length(bad))
            bad_files <- c(bad_files, (allfiles[is_man])[bad])
        bad <- tolower(basename(allfiles))
        ## remove any extension(s) (see 'Writing R Extensions')
        bad <- sub("[.].*", "", bad)
        bad <- grepl("^(con|prn|aux|clock[$]|nul|lpt[1-9]|com[1-9])$", bad)
        bad_files <- c(bad_files, allfiles[bad])
        if (nb <- length(bad_files)) {
            errorLog(Log)
            msg <- ngettext(nb,
                            "Found the following file with a non-portable file name:\n",
                            "Found the following files with non-portable file names:\n",
                            domain = NA)
            wrapLog(msg)
            printLog0(Log, .format_lines_with_indent(bad_files), "\n")
            wrapLog("These are not valid file names",
                    "on all R platforms.\n",
                    "Please rename the files and try again.\n",
                    "See section 'Package structure'",
                    "in the 'Writing R Extensions' manual.\n")
            do_exit(1L)
        }

        ## Next check for name clashes on case-insensitive file systems
        ## (that is on Windows and (by default) on OS X).

        dups <- unique(allfiles[duplicated(tolower(allfiles))])
        if (nb <- length(dups)) {
            errorLog(Log)
            wrapLog("Found the following files with duplicate lower-cased file names:\n")
            printLog0(Log, .format_lines_with_indent(dups), "\n")
            wrapLog("File names must not differ just by case",
                    "to be usable on all R platforms.\n",
                    "Please rename the files and try again.\n",
                    "See section 'Package structure'",
                    "in the 'Writing R Extensions' manual.\n")
            do_exit(1L)
        }

        ## NB: the omission of ' ' is deliberate.
        non_ASCII_files <-
            allfiles[grepl("[^-A-Za-z0-9._!#$%&+,;=@^(){}\'[\\]]", #
                           basename(allfiles), perl = TRUE)]
        any <- FALSE
        if (nb <- length(non_ASCII_files)) {
            any <- TRUE
            warningLog(Log)
            msg <- ngettext(nb,
                            "Found the following file with a non-portable file name:\n",
                            "Found the following files with non-portable file names:\n",
                            domain = NA)
            wrapLog(msg)
            printLog0(Log, .format_lines_with_indent(non_ASCII_files), "\n")
            wrapLog("These are not fully portable file names.\n",
                    "See section 'Package structure'",
                    "in the 'Writing R Extensions' manual.\n")
        }

        ## now check lengths, as tarballs can only record up to 100 bytes
        ## plus perhaps 155 bytes as a prefix plus /
        af <- file.path(pkgname, af)
        lens <- nchar(af, "b")
        if (any(lens > 100L)) {
            bad_files <- af[lens > 100L]
            OK <- TRUE
            if (any(lens > 256L)) OK <- FALSE
            else { # check if can be splt
                for (f in bad_files) {
                    name <- charToRaw(f)
                    s <- max(which(name[1:155] == charToRaw("/")))
                    if(is.infinite(s) || s+100 < length(name)) {
                        OK <- FALSE; break
                    }
                }
                if (!OK) errorLog(Log)
                else if(!any) {
                    noteLog(Log)
                    any <- TRUE
                }
            }
            msg <- ngettext(length(bad_files),
                            "Found the following non-portable file path:\n",
                            "Found the following non-portable file paths:\n",
                            domain = NA)
            wrapLog(msg)
            printLog0(Log, .format_lines_with_indent(bad_files), "\n\n")
            wrapLog("Tarballs are only required to store paths of up to 100",
                    "bytes and cannot store those of more than 256 bytes,",
                    "with restrictions including to 100 bytes for the",
                    "final component.\n",
                    "See section 'Package structure'",
                    "in the 'Writing R Extensions' manual.\n")
            if (!OK) do_exit(1L)
        }
        if (!any) resultLog(Log, "OK")

        allfiles
    }

    check_permissions <- function(allfiles)
    {
        checkingLog(Log, "for sufficient/correct file permissions")

        ## This used to be much more 'aggressive', requiring that dirs
        ## and files have mode >= 00755 and 00644, respectively (with
        ## an error if not), and that files know to be 'text' have
        ## mode 00644 (with a warning if not).  We now only require
        ## that dirs and files have mode >= 00700 and 00400,
        ## respectively, and try to fix insufficient permission in the
        ## INSTALL code (Unix only).
        ##
        ## In addition, we check whether files 'configure' and
        ## 'cleanup' exists in the top-level directory but are not
        ## executable, which is most likely not what was intended.

        ## Phase A.  Directories at least 700, files at least 400.
        bad_files <- character()
        ##                 allfiles <- dir(".", all.files = TRUE,
        ##                                 full.names = TRUE, recursive = TRUE)
        ##                 allfiles <- sub("^./", "", allfiles)
        if(length(allfiles)) {
            mode <- file.info(allfiles)$mode
            bad_files <- allfiles[(mode & "400") < as.octmode("400")]
        }
        if(length(alldirs <- unique(dirname(allfiles)))) {
            mode <- file.info(alldirs)$mode
            bad_files <- c(bad_files,
                           alldirs[(mode & "700") < as.octmode("700")])
        }
        if (length(bad_files)) {
            errorLog(Log)
            wrapLog("Found the following files with insufficient permissions:\n")
            printLog0(Log, .format_lines_with_indent(bad_files), "\n")
            wrapLog("Permissions should be at least 700 for directories and 400 for files.\nPlease fix permissions and try again.\n")
            do_exit(1L)
        }

        ## Phase B.  Top-level scripts 'configure' and 'cleanup'
        ## should really be mode at least 500, or they will not be
        ## necessarily be used (or should we rather change *that*?)
        bad_files <- character()
        for (f in c("configure", "cleanup")) {
            if (!file.exists(f)) next
            mode <- file.info(f)$mode
            if ((mode & "500") < as.octmode("500"))
                bad_files <- c(bad_files, f)
        }
        if (length(bad_files)) {
            warningLog(Log)
            wrapLog("The following files should most likely be executable (for the owner):\n")
            printLog0(Log, .format_lines_with_indent(bad_files), "\n")
            printLog(Log, "Please fix their permissions\n")
        } else resultLog(Log, "OK")
    }

    check_meta <- function()
    {
        ## If we just installed the package (via R CMD INSTALL), we already
        ## validated most of the package DESCRIPTION metadata.  Otherwise,
        ## let us be defensive about this ...

        checkingLog(Log, "DESCRIPTION meta-information")
        dfile <- if (is_base_pkg) "DESCRIPTION.in" else "DESCRIPTION"
        ## FIXME: this does not need to be run in another process
        ## but that needs conversion to format().
        Rcmd <- sprintf("tools:::.check_package_description(\"%s\", TRUE)",
                        dfile)
        out <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=NULL")
        if (length(out)) {
            errorLog(Log)
            printLog0(Log, paste(out, collapse = "\n"), "\n")
            do_exit(1L)
        }
        any <- FALSE
        ## Check the encoding.
        Rcmd <- sprintf("tools:::.check_package_description_encoding(\"%s\")", dfile)
        out <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=NULL")
        if (length(out)) {
            warningLog(Log)
            any <- TRUE
            printLog0(Log, paste(out, collapse = "\n"), "\n")
        }

        ## Check the license.
        ## For base packages, the DESCRIPTION.in files have non-canonical
        ##   License: Part of R @VERSION@
        ## entries because these really are a part of R: hence, skip the
        ## check.
        check_license <- if (!is_base_pkg) {
            Check_license <- Sys.getenv("_R_CHECK_LICENSE_", NA)
            if(is.na(Check_license)) {
                ## The check code conditionalizes *output* on _R_CHECK_LICENSE_.
                Sys.setenv('_R_CHECK_LICENSE_' = "TRUE")
                TRUE
            } else config_val_to_logical(Check_license)
        } else FALSE
        if (!identical(check_license, FALSE)) {
            Rcmd <- sprintf("tools:::.check_package_license(\"%s\", \"%s\")",
                            dfile, pkgdir)
            ## FIXME: this does not need to be run in another process
            out <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=NULL")
            if (length(out)) {
                if (check_license == "maybe") {
                    if (!any) warningLog(Log)
                } else if (any(grepl("^(Standardizable: FALSE|Invalid license file pointers:)",
                                     out))) {
                    if (!any) warningLog(Log)
                } else {
                    if (!any) noteLog(Log)
                }
                any <- TRUE
                printLog0(Log, paste(out, collapse = "\n"), "\n")
            }
        }

        ## .check_package_description() only checks Authors@R "if needed",
        ## and does not check for persons with no valid roles.
        db <- .read_description(dfile)
        if(!is.na(aar <- db["Authors@R"])) {
            out <- .check_package_description_authors_at_R_field(aar,
                                                                 strict = TRUE)
            if(length(out)) {
                if(!any) noteLog(Log)
                any <- TRUE
                out <- .format_check_package_description_authors_at_R_field_results(out)
                printLog0(Log, paste(out, collapse = "\n"), "\n")
            }
            ## and there might be stale Authors and Maintainer fields
            yorig <- db[c("Author", "Maintainer")]
            if(check_incoming &&any(!is.na(yorig))) {
                enc <- db["Encoding"]
                aar <- utils:::.read_authors_at_R_field(aar)
                tmp <- utils:::.format_authors_at_R_field_for_author(aar)
                ## uses strwrap, so will be in current locale
                if(!is.na(enc)) tmp <- iconv(tmp, "", enc)
                y <- c(Author = tmp,
                       Maintainer =
                       utils:::.format_authors_at_R_field_for_maintainer(aar))
                ## ignore formatting as far as possible
                clean_up <- function(x) {
                    x <- gsub("[[:space:]]+", " ", x)
                    x <- sub("^[[:space:]]+", " ", x)
                    sub("^[[:space:]]+$", " ", x)
                }
                yorig <- sapply(yorig, clean_up)
                y <- sapply(y, clean_up)
                diff <- y != yorig
                if(any(diff)) {
                    if(!any) noteLog(Log)
                    any <- TRUE
                    if(diff[1L]) {
                        printLog(Log, "Author field differs from that derived from Authors@R", "\n")
                        printLog(Log, "  Author:    ", sQuote(yorig[1L]), "\n")
                        printLog(Log, "  Authors@R: ", sQuote(y[1L]), "\n")
                        printLog(Log, "\n")
                    }
                    if(diff[2L]) {
                        printLog(Log, "Maintainer field differs from that derived from Authors@R", "\n")
                        printLog(Log, "  Maintainer: ", sQuote(yorig[2L]), "\n")
                        printLog(Log, "  Authors@R:  ", sQuote(y[2L]), "\n")
                        printLog(Log, "\n")
                    }
                }
            }
        }

        out <- format(tools:::.check_package_description2(dfile))
        if (length(out)) {
            if(!any) noteLog(Log)
            any <- TRUE
            printLog0(Log, paste(out, collapse = "\n"), "\n")
        }

        if (!any) resultLog(Log, "OK")
    }

    check_build <- function()
    {
        fv <- file.path("build", "vignette.rds")
        if(!file.exists(fv)) return()
        checkingLog(Log, "'build' directory")
        any <- FALSE
        db <- readRDS(fv)
        ## do as CRAN-pack does
        keep <- nzchar(db$PDF)
        if(any(!keep)) {
            if(!any) warningLog(Log)
            any <- TRUE
            msg <- c("Vignette(s) without any output listed in 'build/vignette.rds'",
                     strwrap(sQuote(db$file[!keep]), indent = 2L, exdent = 2L))
            printLog0(Log, paste(msg, collapse = "\n"), "\n")
        }
        pdfs <- file.path("inst", "doc", db[keep, ]$PDF)
        missing <- !file.exists(pdfs)
        if(any(missing)) {
            if(!any) warningLog(Log)
            any <- TRUE
            msg <- c("Output(s) listed in 'build/vignette.rds' but not in package:",
                     strwrap(sQuote(pdfs[missing]), indent = 2L, exdent = 2L))
            printLog0(Log, paste(msg, collapse = "\n"), "\n")
        }
        if (!any) resultLog(Log, "OK")
    }

    check_top_level <- function()
    {
        checkingLog(Log, "top-level files")
        topfiles <- Sys.glob(c("install.R", "R_PROFILE.R"))
        any <- FALSE
        if (length(topfiles)) {
            any <- TRUE
            warningLog(Log)
            printLog0(Log, .format_lines_with_indent(topfiles), "\n")
            wrapLog("These files are defunct.",
                    "See manual 'Writing R Extensions'.\n")
        }
        topfiles <- Sys.glob(c("LICENCE", "LICENSE"))
        if (length(topfiles)) {
            ## Are these mentioned in DESCRIPTION?
            lic <- desc["License"]
            if(!is.na(lic)) {
                found <- sapply(topfiles,
                                function(x) grepl(x, lic, fixed = TRUE))
                topfiles <- topfiles[!found]
                if (length(topfiles)) {
                    if(!any) noteLog(Log)
                    any <- TRUE
                    one <- (length(topfiles) == 1L)
                    msg <- c(if(one) "File" else "Files",
                             "\n",
                             .format_lines_with_indent(topfiles),
                             "\n",
                             if(one) {
                                 "is not mentioned in the DESCRIPTION file.\n"
                             } else {
                                 "are not mentioned in the DESCRIPTION file.\n"
                             })
                    printLog(Log, msg)
                }
            }
        }
        topfiles <- Sys.glob(file.path("inst", c("LICENCE", "LICENSE")))
        if (length(topfiles)) {
            ## Are these mentioned in DESCRIPTION?
            lic <- desc["License"]
            if(!is.na(lic)) {
                found <- sapply(basename(topfiles),
                                function(x) grepl(x, lic, fixed = TRUE))
                topfiles <- topfiles[!found]
                if (length(topfiles)) {
                    if(!any) noteLog(Log)
                    any <- TRUE
                    one <- (length(topfiles) == 1L)
                    msg <- c(if(one) "File" else "Files",
                             "\n",
                             .format_lines_with_indent(topfiles),
                             "\n",
                             if(one) {
                                 "will install at top-level and is not mentioned in the DESCRIPTION file.\n"
                             } else {
                                 "will install at top-level and are not mentioned in the DESCRIPTION file.\n"
                             })
                    printLog(Log, msg)
                }
            }
        }
        if (!is_base_pkg && R_check_toplevel_files) {
            ## any others?
            if(is.null(topfiles0)) {
                topfiles <- dir()
                ## Now check if any of these were created since we started
                topfiles <- topfiles[file.info(topfiles)$ctime <= .unpack.time]
            } else topfiles <- topfiles0
            known <- c("DESCRIPTION", "INDEX", "LICENCE", "LICENSE",
                       "LICENCE.note", "LICENSE.note",
                       "MD5", "NAMESPACE", "NEWS", "PORTING",
                       "COPYING", "COPYING.LIB", "GPL-2", "GPL-3",
                       "BUGS", "Bugs",
                       "ChangeLog", "Changelog", "CHANGELOG", "CHANGES", "Changes",
                       "INSTALL", "README", "THANKS", "TODO", "ToDo",
                       "INSTALL.windows",
                       "README.md",   # seems popular
                       "configure", "configure.win", "cleanup", "cleanup.win",
                       "configure.ac", "configure.in",
                       "datafiles",
                       "R", "data", "demo", "exec", "inst", "man",
                       "po", "src", "tests", "vignettes",
                       "build",       # used by R CMD build
                       ".aspell",     # used for spell checking packages
                       "java", "tools") # common dirs in packages.
            topfiles <- setdiff(topfiles, known)
            if (file.exists(file.path("inst", "AUTHORS")))
                topfiles <- setdiff(topfiles, "AUTHORS")
            if (file.exists(file.path("inst", "COPYRIGHTS")))
                topfiles <- setdiff(topfiles, "COPYRIGHTS")
            if (lt <- length(topfiles)) {
                if(!any) noteLog(Log)
                any <- TRUE
                printLog(Log, ## dirs are files, but maybe not on Windows
                         if(lt > 1L) "Non-standard files/directories found at top level:\n"
                         else "Non-standard file/directory found at top level:\n" )
                msg <- strwrap(paste(sQuote(topfiles), collapse = " "),
                               indent = 2L, exdent = 2L)
                printLog0(Log, paste(c(msg, ""), collapse="\n"))
                cp <- grep("^copyright", topfiles,
                           ignore.case = TRUE, value = TRUE)
                if (length(cp))
                    printLog(Log, "Copyright information should be in file inst/COPYRIGHTS\n")
                if("AUTHORS" %in% topfiles)
                    printLog(Log, "Authors information should be in file inst/AUTHORS\n")
            }
        }
        if (!any) resultLog(Log, "OK")
    }

    check_detritus <- function()
    {
        checkingLog(Log, "for left-over files")
        files <- dir(".", full.names = TRUE, recursive = TRUE)
        bad <- grep("svn-commit[.].*tmp$", files, value = TRUE)
        bad <- c(bad, grep("^[.]/[^/]*[.][rR]d$", files, value = TRUE))
        if (length(bad)) {
            bad <- sub("^[.]/", paste0(pkgname, "/"), bad)
            noteLog(Log)
            printLog0(Log,
                      "The following files look like leftovers:\n",
                      paste(strwrap(paste(sQuote(bad), collapse = ", "),
                                    indent = 2, exdent = 2), collapse = "\n"),
                      "\nPlease remove them from your package.\n")
        } else resultLog(Log, "OK")
    }


    check_indices <- function()
    {
        ## Check index information.
        checkingLog(Log, "index information")
        any <- FALSE
        if (file.exists("INDEX") &&
            !length(readLines("INDEX", warn = FALSE))) {
            any <- TRUE
            warningLog(Log, "Empty file 'INDEX'.")
        }
        if (dir.exists("demo")) {
            index <- file.path("demo", "00Index")
            if (!file.exists(index) ||
                !length(readLines(index, warn = FALSE))) {
                if(!any) warningLog(Log)
                any <- TRUE
                printLog0(Log,
                          sprintf("Empty or missing file %s.\n",
                                  sQuote(index)))
            } else {
                Rcmd <- "options(warn=1)\ntools:::.check_demo_index(\"demo\")\n"
                ## FIXME: this does not need to be run in another process
                out <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=NULL")
                if(length(out)) {
                    if(!any) warningLog(Log)
                    any <- TRUE
                    printLog0(Log, paste(c(out, ""), collapse = "\n"))
                }
            }
        }
        if (dir.exists(file.path("inst", "doc"))) {
            Rcmd <- "options(warn=1)\ntools:::.check_vignette_index(\"inst/doc\")\n"
            ## FIXME: this does not need to be run in another process
            out <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=NULL")
            if(length(out)) {
                if(!any) warningLog(Log)
                any <- TRUE
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
            }
        }
        if (any)
            wrapLog("See the information on INDEX files and package",
                    "subdirectories in the chapter 'Creating R packages'",
                    "of the 'Writing R Extensions' manual.\n")
        else  resultLog(Log, "OK")
    }

    check_subdirectories <- function(haveR, subdirs)
    {
        checkingLog(Log, "package subdirectories")
        any <- FALSE
        if (haveR && !length(list_files_with_type("R", "code")) &&
            !file.exists(file.path("R", "sysdata.rda"))) {
            haveR <- FALSE
            warningLog(Log, "Found directory 'R' with no source files.")
            any <- TRUE
        }
        if (R_check_subdirs_nocase) {
            ## Argh.  We often get submissions where 'R' comes out as 'r',
            ## or 'man' comes out as 'MAN', and we've just ran into 'DATA'
            ## instead of 'data' (2007-03-31).  Maybe we should warn about
            ## this unconditionally ...
            ## <FIXME>
            ## Actually, what we should really do is check whether there is
            ## any directory with lower-cased name matching a lower-cased
            ## name of a standard directory, while differing in name.
            ## </FIXME>

            ## Watch out for case-insensitive file systems
            if ("./r" %in% list.dirs(recursive = FALSE)) {
                if (!any) warningLog(Log)
                any <- TRUE
                printLog(Log, "Found subdirectory 'r'.\n",
                         "Most likely, this should be 'R'.\n")
            }
            if ("./MAN" %in% list.dirs(recursive = FALSE)) {
                if (!any) warningLog(Log)
                any <- TRUE
                printLog(Log, "Found subdirectory 'MAN'.\n",
                         "Most likely, this should be 'man'.\n")
            }
            if ("./DATA" %in% list.dirs(recursive = FALSE)) {
                if (!any) warningLog(Log)
                any <- TRUE
                printLog(Log, "Found subdirectory 'DATA'.\n",
                         "Most likely, this should be 'data'.\n")
            }
        }

        all_dirs <- list.dirs(".")

        ## several packages have had check dirs in the sources, e.g.
        ## ./languageR/languageR.Rcheck
        ## ./locfdr/man/locfdr.Rcheck
        ## ./clustvarsel/inst/doc/clustvarsel.Rcheck
        ## ./bicreduc/OldFiles/bicreduc.Rcheck
        ## ./waved/man/waved.Rcheck
        ## ./waved/..Rcheck
        ind <- grepl("\\.Rcheck$", all_dirs)
        if(any(ind)) {
            if(!any) warningLog(Log)
            any <- TRUE
            msg <- ngettext(sum(ind),
                            "Found the following directory with the name of a check directory:\n",
                            "Found the following directories with names of check directories:\n", domain = NA)
            printLog0(Log, msg,
                      .format_lines_with_indent(all_dirs[ind]),
                      "\n",
                      "Most likely, these were included erroneously.\n")
        }

        ## Several packages had leftover Rd2dvi build directories in
        ## their sources
        ind <- grepl("^\\.Rd2(dvi|pdf)", basename(all_dirs))
        if(any(ind)) {
            if(!any) warningLog(Log)
            any <- TRUE
            msg <- ngettext(sum(ind),
                            "Found the following directory with the name of a Rd2pdf directory:\n",
                            "Found the following directories with names of Rd2pdf directories:\n", domain = NA)
           printLog0(Log, msg,
                     .format_lines_with_indent(all_dirs[ind]),
                     "\n",
                     "Most likely, these were included erroneously.\n")
        }


        if(!is_base_pkg && (istar || R_check_vc_dirs)) {
            ## Packages also should not contain version control subdirs
            ## provided that we check a .tar.gz or know we unpacked one.
            ind <- basename(all_dirs) %in% .vc_dir_names
            if(any(ind)) {
                if(!any) warningLog(Log)
                any <- TRUE
            msg <- ngettext(sum(ind),
                            "Found the following directory with the name of a version control directory:\n",
                            "Found the following directories with names of version control directories:\n", domain = NA)
                printLog0(Log, msg,
                          .format_lines_with_indent(all_dirs[ind]),
                          "\n",
                          "These should not be in a package tarball.\n")
            }
        }

        if (subdirs != "no") {
            Rcmd <- "tools:::.check_package_subdirs(\".\")\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.
            out <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=NULL")
            if(length(out)) {
                if(!any) warningLog(Log)
                any <- TRUE
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
                wrapLog("Please remove or rename the files.\n",
                        "See section 'Package subdirectories'",
                        "in the 'Writing R Extensions' manual.\n")
            }
        }

        ## Subdirectory 'data' without data sets?
        if (dir.exists("data") &&
            !length(list_files_with_type("data", "data"))) {
            if (!any) warningLog(Log)
            any <- TRUE
            printLog(Log, "Subdirectory 'data' contains no data sets.\n")
       }
        ## Subdirectory 'demo' without demos?

        if (dir.exists("demo")) {
            demos <- list_files_with_type("demo", "demo")
            if(!length(demos)) {
                if (!any) warningLog(Log)
                any <- TRUE
                printLog(Log, "Subdirectory 'demo' contains no demos.\n")
            } else {
                ## check for non-ASCII code in each demo
                bad <- character()
                for(d in demos) {
                    x <- readLines(d, warn = FALSE)
                    asc <- iconv(x, "latin1", "ASCII")
                    ind <- is.na(asc) | asc != x
                    if (any(ind)) bad <- c(bad, basename(d))
                }
                if (length(bad)) {
                    if (!any) warningLog(Log)
                    any <- TRUE
                    printLog(Log, "Demos with non-ASCII characters:")
                    if(length(bad) > 1L)
                        printLog0(Log, "\n",
                                  .format_lines_with_indent(bad), "\n")
                    else printLog0(Log, "  ", bad, "\n")
                    wrapLog("Portable packages must use only ASCII",
                            "characters in their demos.\n",
                            "Use \\uxxxx escapes for other characters.\n")
                    demos <- demos[! basename(demos) %in% bad]
                }
                ## check we can parse each demo.
                bad <- character()
                for(d in demos)
                    tryCatch(parse(file = d),
                             error = function(e) bad <<- c(bad, basename(d)))
                if (length(bad)) {
                    if (!any) warningLog(Log)
                    any <- TRUE
                    printLog(Log, "Demos which do not contain valid R code:")
                    if(length(bad) > 1L)
                        printLog0(Log, "\n",
                                  .format_lines_with_indent(bad), "\n")
                    else printLog0(Log, "  ", bad, "\n")
               }
            }
        }

        ## Subdirectory 'exec' without files?
        if (dir.exists("exec") && !length(dir("exec"))) {
            if (!any) warningLog(Log)
            any <- TRUE
            printLog(Log, "Subdirectory 'exec' contains no files.\n")
        }

        ## Subdirectory 'inst' without files?
        if (dir.exists("inst") && !length(dir("inst", recursive = TRUE))) {
            if (!any) warningLog(Log)
            any <- TRUE
            printLog(Log, "Subdirectory 'inst' contains no files.\n")
        }

        ## Subdirectory 'src' without sources?
        if (dir.exists("src")) {
            ## <NOTE>
            ## If there is a Makefile (or a Makefile.win), we cannot assume
            ## that source files have the predefined extensions.
            ## </NOTE>
            if (!any(file.exists(file.path("src",
                                           c("Makefile", "Makefile.win",
                                             "install.libs.R"))))) {
                if (!length(dir("src", pattern = "\\.([cfmM]|cc|cpp|f90|f95|mm)"))) {
                    if (!any) warningLog(Log)
                    printLog(Log, "Subdirectory 'src' contains no source files.\n")
                    any <- TRUE
                }
            }
        }

        ## Do subdirectories of 'inst' interfere with R package system
        ## subdirectories?
        if (dir.exists("inst")) {
            ## These include pre-2.10.0 ones
            R_system_subdirs <-
                c("Meta", "R", "data", "demo", "exec", "libs",
                  "man", "help", "html", "latex", "R-ex", "build")
            allfiles <- dir("inst", full.names = TRUE)
            alldirs <- allfiles[file.info(allfiles)$isdir]
            suspect <- basename(alldirs) %in% R_system_subdirs
            if (any(suspect)) {
                ## check they are non-empty
                suspect <- alldirs[suspect]
                suspect <- suspect[sapply(suspect, function(x) {
                    length(dir(x, all.files = TRUE)) > 2L
                })]
                if (length(suspect)) {
                    if (!any) warningLog(Log)
                    any <- TRUE
                    wrapLog("Found the following non-empty",
                            "subdirectories of 'inst' also",
                            "used by R:\n")
                    printLog0(Log, .format_lines_with_indent(suspect), "\n")
                    wrapLog("It is recommended not to interfere",
                            "with package subdirectories used by R.\n")
                }
            }
        }

        ## Valid NEWS.Rd?
        nfile <- file.path("inst", "NEWS.Rd")
        if(file.exists(nfile)) {
            ## Catch all warning and error messages.
            ## We use the same construction in at least another place,
            ## so maybe factor out a common utility function
            ##   .try_catch_all_warnings_and_errors
            ## eventually.
            ## For testing package NEWS.Rd files, we really need a real
            ## QC check function eventually ...
            .warnings <- NULL
            .error <- NULL
            withCallingHandlers(tryCatch(.build_news_db_from_package_NEWS_Rd(nfile),
                                         error = function(e)
                                         .error <<- conditionMessage(e)),
                                warning = function(e) {
                                    .warnings <<- c(.warnings,
                                                    conditionMessage(e))
                                    invokeRestart("muffleWarning")
                                })
            msg <- c(.warnings, .error)
            if(length(msg)) {
                if(!any) warningLog(Log)
                any <- TRUE
                printLog(Log, "Problems with news in 'inst/NEWS.Rd':\n")
                printLog0(Log,
                          paste("  ",
                                unlist(strsplit(msg, "\n", fixed = TRUE)),
                                sep = "", collapse = "\n"),
                          "\n")
            }
        }

        ## Valid CITATION metadata?
        if (file.exists(file.path("inst", "CITATION"))) {
            Rcmd <- if(do_install)
                sprintf("tools:::.check_citation(\"inst/CITATION\", \"%s\")\n",
                        file.path(if(is_base_pkg) .Library else libdir,
                                  pkgname))
            else
                "tools:::.check_citation(\"inst/CITATION\")\n"
            out <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=utils")
            if(length(out)) {
                if(!any) warningLog(Log)
                any <- TRUE
                printLog(Log,
                         "Invalid citation information in 'inst/CITATION':\n")
                printLog0(Log, .format_lines_with_indent(out), "\n")
            }
        }

        ## CITATION files in non-standard places?
        ## Common problems: rather than inst/CITATION, have
        ##   CITATION
        ##   CITATION.txt
        ##   inst/doc/CITATION
        ## Of course, everything in inst is justifiable, so only give a
        ## note for now.
        files <- dir(".", pattern = "^CITATION.*", recursive = TRUE)
        files <- files[file_path_sans_ext(basename(files)) == "CITATION" &
                       files != file.path("inst", "CITATION")]
        if(length(files)) {
            if(!any) noteLog(Log)
            any <- TRUE
            msg <- ngettext(length(files),
                            "Found the following CITATION file in a non-standard place:\n",
                            "Found the following CITATION files in a non-standard place:\n", domain = NA)
            wrapLog(msg)
            printLog0(Log, .format_lines_with_indent(files), "\n")
            wrapLog("Most likely 'inst/CITATION' should be used instead.\n")
        }

        if(!any) resultLog(Log, "OK")
    }

    check_non_ASCII <- function()
    {
        checkingLog(Log, "R files for non-ASCII characters")
        out <- R_runR("tools:::.check_package_ASCII_code('.')",
                      R_opts2, "R_DEFAULT_PACKAGES=NULL")
        if (length(out)) {
            warningLog(Log)
            msg <- ngettext(length(out),
                            "Found the following file with non-ASCII characters:\n",
                            "Found the following files with non-ASCII characters:\n",
                            domain = NA)
            wrapLog(msg)
            printLog0(Log, .format_lines_with_indent(out), "\n")
            wrapLog("Portable packages must use only ASCII",
                    "characters in their R code,\n",
                    "except perhaps in comments.\n",
                    "Use \\uxxxx escapes for other characters.\n")
        } else resultLog(Log, "OK")

        checkingLog(Log, "R files for syntax errors")
        Rcmd  <- "options(warn=1);tools:::.check_package_code_syntax(\"R\")"
        out <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=NULL")
        if (any(grepl("^Error", out))) {
            errorLog(Log)
            printLog0(Log, paste(c(out, ""), collapse = "\n"))
            do_exit(1L)
        } else if (length(out)) {
            warningLog(Log)
            printLog0(Log, paste(c(out, ""), collapse = "\n"))
        } else resultLog(Log, "OK")
    }

    check_R_code <- function()
    {
        if (!is_base_pkg) {
            checkingLog(Log, "dependencies in R code")
            if (do_install) {
                Rcmd <- paste("options(warn=1, showErrorCalls=FALSE)\n",
                              sprintf("tools:::.check_packages_used(package = \"%s\")\n", pkgname))

                out <- R_runR2(Rcmd, "R_DEFAULT_PACKAGES=NULL")
                if (length(out)) {
                    if(any(grepl("(not declared from|Including base/recommended)", out))) warningLog(Log)
                    else noteLog(Log)
                    printLog0(Log, paste(c(out, ""), collapse = "\n"))
                    wrapLog(msg_DESCRIPTION)
                } else resultLog(Log, "OK")
            } else {
                ## this needs to read the package code, and will fail on
                ## syntax errors such as non-ASCII code.
                Rcmd <- paste("options(warn=1, showErrorCalls=FALSE)\n",
                              sprintf("tools:::.check_packages_used(dir = \"%s\")\n", pkgdir))

                out <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=NULL")
                if (length(out)) {
                    if(any(grepl("not declared from", out))) warningLog(Log)
                    else noteLog(Log)
                    printLog0(Log, paste(c(out, ""), collapse = "\n"))
                    wrapLog(msg_DESCRIPTION)
                } else resultLog(Log, "OK")
            }
        }

        ## Check whether methods have all arguments of the corresponding
        ## generic.
        checkingLog(Log, "S3 generic/method consistency")
        Rcmd <- paste("options(warn=1)\n",
                      "options(expressions=1000)\n",
                      if (do_install)
                      sprintf("tools::checkS3methods(package = \"%s\")\n", pkgname)
                      else
                      sprintf("tools::checkS3methods(dir = \"%s\")\n", pkgdir))
        out <- R_runR2(Rcmd)
        if (length(out)) {
            warningLog(Log)
            printLog0(Log, paste(c(out, ""), collapse = "\n"))
            wrapLog("See section 'Generic functions and methods'",
                    "of the 'Writing R Extensions' manual.\n")
        } else resultLog(Log, "OK")

        ## Check whether replacement functions have their final argument
        ## named 'value'.
        checkingLog(Log, "replacement functions")
        Rcmd <- paste("options(warn=1)\n",
                      if (do_install)
                      sprintf("tools::checkReplaceFuns(package = \"%s\")\n", pkgname)
                      else
                      sprintf("tools::checkReplaceFuns(dir = \"%s\")\n", pkgdir))
        out <- R_runR2(Rcmd)
        if (length(out)) {
            ## <NOTE>
            ## We really want to stop if we find offending replacement
            ## functions.  But we cannot use error() because output may
            ## contain warnings ...
            warningLog(Log)
            ## </NOTE>
            printLog0(Log, paste(c(out, ""), collapse = "\n"))
            wrapLog("The argument of a replacement function",
                    "which corresponds to the right hand side",
                    "must be named 'value'.\n")
        } else resultLog(Log, "OK")

        ## Check foreign function calls.
        ## The neverending story ...
        ## For the time being, allow to turn this off by setting the environment
        ## variable _R_CHECK_FF_CALLS_ to an empty value.
        if (nzchar(R_check_FF)) {
            registration <-
                identical(R_check_FF, "registration") && install != "fake"
            checkingLog(Log, "foreign function calls")
            DUP <- R_check_FF_DUP
            if(as_cran) {
                Sys.setenv("_R_CHECK_FF_AS_CRAN_" = "TRUE")
                DUP <- TRUE
            }
            Rcmd <- paste("options(warn=1)\n",
                          if (do_install)
                          sprintf("tools::checkFF(package = \"%s\", registration = %s, check_DUP = %s)\n",
                                  pkgname, registration, DUP)
                          else
                          sprintf("tools::checkFF(dir = \"%s\", registration = %s, check_DUP = %s)\n",
                                  pkgdir, "FALSE", DUP))
            out <- R_runR2(Rcmd)
            Sys.unsetenv("_R_CHECK_FF_AS_CRAN_")
            if (length(out)) {
                if(any(grepl("^Foreign function calls? with(out| empty)", out)) ||
                   (!is_base_pkg && any(grepl("to a base package:", out))) ||
                   any(grepl("^Undeclared packages? in", out)) ||
                   any(grepl("parameter[s]*, expected ", out))
                   ) warningLog(Log)
                else noteLog(Log)
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
                if(!is_base_pkg && any(grepl("to a base package:", out)))
                    wrapLog("Packages should not make",
                            ".C/.Call/.External/.Fortran",
                            "calls to a base package.",
                            "They are not part of the API,",
                            "for use only by R itself",
                            "and subject to change without notice.")
                else if(any(grepl("with DUP = FALSE:", out)))
                    wrapLog("DUP = FALSE is deprecated and may be",
                            "disabled in future versions of R.")
                else
                    wrapLog("See the chapter 'System and foreign language interfaces' of the 'Writing R Extensions' manual.\n")
            } else resultLog(Log, "OK")
        }
    }

    check_R_files <- function(is_rec_pkg)
    {
        checkingLog(Log, "R code for possible problems")
        if (!is_base_pkg) {
            Rcmd <- paste("options(warn=1)\n",
                          sprintf("tools:::.check_package_code_shlib(dir = \"%s\")\n",
                                  pkgdir))
            out <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=NULL")
            if (length(out)) {
                errorLog(Log)
                wrapLog("Incorrect (un)loading of package",
                        "shared object.\n")
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
                wrapLog("The system-specific extension for",
                        "shared objects must not be added.\n",
                        "See ?library.dynam.\n")
                do_exit(1L)
            }
        }

        Rcmd <- paste("options(warn=1)\n",
                      sprintf("tools:::.check_package_code_startup_functions(dir = \"%s\")\n",
                              pkgdir))
        out1 <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=")
        Rcmd <- paste("options(warn=1)\n",
                      sprintf("tools:::.check_package_code_unload_functions(dir = \"%s\")\n",
                              pkgdir))
        out1a <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=")
        out1 <- if (length(out1) && length(out1a)) c(out1, "", out1a)
                else c(out1, out1a)

        out2 <- out3 <- out4 <- out5 <- out6 <- out7 <- out8 <- NULL

        if (!is_base_pkg && R_check_unsafe_calls) {
            Rcmd <- paste("options(warn=1)\n",
                          sprintf("tools:::.check_package_code_tampers(dir = \"%s\")\n",
                                  pkgdir))
            out2 <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=NULL")
        }

        if (R_check_use_codetools && do_install) {
            Rcmd <-
                paste("options(warn=1)\n",
                      sprintf("tools:::.check_code_usage_in_package(package = \"%s\")\n", pkgname))
            out3 <- R_runR2(Rcmd, "R_DEFAULT_PACKAGES=")
        }

        if(!is_base_pkg && R_check_use_codetools && R_check_dot_internal) {
            details <- pkgname != "relax" # has .Internal in a 10,000 line fun
            Rcmd <- paste("options(warn=1)\n",
                          if (do_install)
                              sprintf("tools:::.check_dotInternal(package = \"%s\",details=%s)\n", pkgname, details)
                          else
                              sprintf("tools:::.check_dotInternal(dir = \"%s\",details=%s)\n", pkgdir, details))
            out4 <- R_runR2(Rcmd, "R_DEFAULT_PACKAGES=")
            ## Hmisc, gooJSON, quantmod give spurious output
            if (!any(grepl("^Found.* .Internal call", out4))) out4 <- NULL
        }

        if(!is_base_pkg && R_check_code_assign_to_globalenv) {
            Rcmd <- paste("options(warn=1)\n",
                          sprintf("tools:::.check_package_code_assign_to_globalenv(dir = \"%s\")\n",
                                  pkgdir))
            out5 <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=")
        }

        if(!is_base_pkg && R_check_code_attach) {
            Rcmd <- paste("options(warn=1)\n",
                          sprintf("tools:::.check_package_code_attach(dir = \"%s\")\n",
                                  pkgdir))
            out6 <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=")
        }
        if(!is_base_pkg && R_check_code_data_into_globalenv) {
            Rcmd <- paste("options(warn=1)\n",
                          sprintf("tools:::.check_package_code_data_into_globalenv(dir = \"%s\")\n",
                                  pkgdir))
            out7 <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=")
        }


        ## Use of deprecated, defunct and platform-specific devices?
        if(!is_base_pkg && R_check_use_codetools && R_check_depr_def) {
            win <- !is.na(OS_type) && OS_type == "windows"
            Rcmd <- paste("options(warn=1)\n",
                          if (do_install)
                              sprintf("tools:::.check_depdef(package = \"%s\", WINDOWS = %s)\n", pkgname, win)
                          else
                              sprintf("tools:::.check_depdef(dir = \"%s\", WINDOWS = %s)\n", pkgdir, win))
            out8 <- R_runR2(Rcmd, "R_DEFAULT_PACKAGES=")
        }

        if (length(out1) || length(out2) || length(out3) ||
            length(out4) || length(out5) || length(out6) ||
            length(out7) || length(out8)) {
            ini <- character()
            if(length(out4) ||
               length(grep("^Found the defunct/removed function", out8)))
                warningLog(Log) else noteLog(Log)
            if (length(out4)) {
                first <- grep("^Found.* .Internal call", out4)[1L]
                if(first > 1L) out4 <- out4[-seq_len(first-1)]
                printLog0(Log, paste(c(ini, out4, "", ""), collapse = "\n"))
                wrapLog(c("Packages should not call .Internal():",
                          "it is not part of the API,",
                          "for use only by R itself",
                          "and subject to change without notice."))
                ini <- ""
            }
            if (length(out8)) {
                printLog0(Log, paste(c(ini, out8, ""), collapse = "\n"))
                if(length(grep("^Found the defunct/removed function", out8)))
                    ini <- ""
            }
            ## All remaining checks give notes and not warnings.
            if(length(ini))
                ini <- c("",
                         "In addition to the above warning(s), found the following notes:",
                         "")

            if (length(out1)) {
                printLog0(Log, paste(c(ini, out1, ""), collapse = "\n"))
                ini <- ""
            }
            if (length(out2)) {
                printLog0(Log,
                          paste(c(ini,
                                  "Found the following possibly unsafe calls:",
                                  out2, ""),
                                collapse = "\n"))
                ini <- ""
            }
            if (length(out3)) {
                printLog0(Log, paste(c(ini, out3, ""), collapse = "\n"))
                ini <- ""
            }
            if (length(out5)) {
                printLog0(Log, paste(c(ini, out5, ""), collapse = "\n"))
                ini <- ""
            }
            if (length(out6)) {
                printLog0(Log, paste(c(ini, out6, ""), collapse = "\n"))
                ini <- ""
                wrapLog(gettextf("See section %s in '%s'.",
                                 sQuote("Good practice"), "?attach"))
           }
            if (length(out7)) {
                printLog0(Log, paste(c(ini, out7, ""), collapse = "\n"))
                ini <- ""
                wrapLog(gettextf("See section %s in '%s'.",
                                 sQuote("Good practice"), "?data"))
            }
        } else resultLog(Log, "OK")
    }

    check_Rd_files <- function(haveR)
    {
        msg_writing_Rd <-
            c("See the chapter 'Writing R documentation files'",
              "in the 'Writing R Extensions' manual.\n")

        if (dir.exists("man") && !extra_arch) {
            checkingLog(Log, "Rd files")
            minlevel <- Sys.getenv("_R_CHECK_RD_CHECKRD_MINLEVEL_", "-1")
            Rcmd <- paste("options(warn=1)\n",
                          sprintf("tools:::.check_package_parseRd('.', minlevel=%s)\n", minlevel))
            out <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=NULL")
            if (length(out)) {
                if(length(grep("^prepare.*Dropping empty section", out,
                               invert = TRUE)))
                    warningLog(Log)
                else noteLog(Log)
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
            } else resultLog(Log, "OK")

            checkingLog(Log, "Rd metadata")
            Rcmd <- paste("options(warn=1)\n",
                          if (do_install)
                          sprintf("tools:::.check_Rd_metadata(package = \"%s\")\n", pkgname)
                          else
                          sprintf("tools:::.check_Rd_metadata(dir = \"%s\")\n", pkgdir))
            out <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=NULL")
            if (length(out)) {
                warningLog(Log)
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
            } else resultLog(Log, "OK")
        }

        ## Check Rd line widths.
        if(dir.exists("man") && R_check_Rd_line_widths) {
            checkingLog(Log, "Rd line widths")
            Rcmd <- paste("options(warn=1)\n",
                          if(do_install)
                          sprintf("tools:::.check_Rd_line_widths(\"%s\", installed = TRUE)\n",
                                  file.path(if(is_base_pkg) .Library else libdir,
                                            pkgname))
                          else
                          sprintf("tools:::.check_Rd_line_widths(\"%s\")\n",
                                  pkgdir))
            out <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=NULL")
            if(length(out)) {
                noteLog(Log)
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
                wrapLog("These lines will be truncated in the PDF manual.\n")

            } else resultLog(Log, "OK")
        }

        ## Check cross-references in R documentation files.

        ## <NOTE>
        ## Installing a package warns about missing links (and hence R CMD
        ## check knows about this too provided an install log is used).
        ## However, under Windows the install-time check verifies the links
        ## against what is available in the default library, which might be
        ## considerably more than what can be assumed to be available.
        ##
        ## The formulations in section "Cross-references" of R-exts are not
        ## quite clear about this, but CRAN policy has for a long time
        ## enforced anchoring links to targets (aliases) from non-base
        ## packages.
        ## </NOTE>

        if (dir.exists("man") && R_check_Rd_xrefs) {
            checkingLog(Log, "Rd cross-references")
            Rcmd <- paste("options(warn=1)\n",
                          if (do_install)
                          sprintf("tools:::.check_Rd_xrefs(package = \"%s\")\n", pkgname)
                          else
                          sprintf("tools:::.check_Rd_xrefs(dir = \"%s\")\n", pkgdir))
            out <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=NULL")
            if (length(out)) {
                if (!all(grepl("Package[s]? unavailable to check", out)))
                    warningLog(Log)
                else noteLog(Log)
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
            } else resultLog(Log, "OK")
        }

        ## Check for missing documentation entries.
        if (!extra_arch && (haveR || dir.exists("data"))) {
            checkingLog(Log, "for missing documentation entries")
            Rcmd <- paste("options(warn=1)\n",
                          if (do_install)
                          sprintf("tools::undoc(package = \"%s\")\n", pkgname)
                          else
                          sprintf("tools::undoc(dir = \"%s\")\n", pkgdir))
            ## This is needed to pick up undocumented S4 classes.
            ## even for packages which only import methods.
            ## But as that check needs to run get() on all the lazy-loaded
            ## promises, avoid if possible.
            ## desc exists in the body of this function.
            use_methods <- if(pkgname == "methods") TRUE else {
                pi <- .split_description(desc)
                "methods" %in% c(names(pi$Depends), names(pi$Imports))
            }
            out <- if (use_methods) {
                env <- if(WINDOWS) "R_DEFAULT_PACKAGES=utils,grDevices,graphics,stats,methods" else "R_DEFAULT_PACKAGES='utils,grDevices,graphics,stats,methods'"
                R_runR2(Rcmd, env = env)
            } else R_runR2(Rcmd)
            ## Grr, get() in undoc can change the search path
            ## Current example is TeachingDemos
            out <- grep("^Loading required package:", out,
                        invert = TRUE, value = TRUE)
            err <- grep("^Error", out)
            if (length(err)) {
                errorLog(Log)
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
                do_exit(1L)
            } else if (length(out)) {
                warningLog(Log)
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
                wrapLog("All user-level objects",
                        "in a package",
                        if (any(grepl("^Undocumented S4", out)))
                        "(including S4 classes and methods)",
                        "should have documentation entries.\n")
                wrapLog(msg_writing_Rd)
            } else resultLog(Log, "OK")
        }

        ## Check for code/documentation mismatches.
        if (dir.exists("man") && !extra_arch) {
            checkingLog(Log, "for code/documentation mismatches")
            if (!do_codoc) resultLog(Log, "SKIPPED")
            else {
                any <- FALSE
                ## Check for code/documentation mismatches in functions.
                if (haveR) {
                    Rcmd <- paste("options(warn=1)\n",
                                  if (do_install)
                                  sprintf("tools::codoc(package = \"%s\")\n", pkgname)
                                  else
                                  sprintf("tools::codoc(dir = \"%s\")\n", pkgdir))
                    out <- R_runR2(Rcmd)
                    if (length(out)) {
                        any <- TRUE
                        warningLog(Log)
                        printLog0(Log, paste(c(out, ""), collapse = "\n"))
                    }
                }

                ## Check for code/documentation mismatches in data sets.
                if (do_install) {
                    Rcmd <- paste("options(warn=1)\n",
                                  sprintf("tools::codocData(package = \"%s\")\n", pkgname))
                    out <- R_runR2(Rcmd)
                    if (length(out)) {
                        if (!any) warningLog(Log)
                        any <- TRUE
                        printLog0(Log, paste(c(out, ""), collapse = "\n"))
                    }
                }

                ## Check for code/documentation mismatches in S4 classes.
                if (do_install && haveR) {
                    Rcmd <- paste("options(warn=1)\n",
                                  sprintf("tools::codocClasses(package = \"%s\")\n", pkgname))
                    out <- R_runR2(Rcmd)
                    if (length(out)) {
                        if (!any) warningLog(Log)
                        any <- TRUE
                        printLog0(Log, paste(c(out, ""), collapse = "\n"))
                    }
                }

                if (!any) resultLog(Log, "OK")
            }
        }

        ## Check Rd files, for consistency of \usage with \arguments (are
        ## all arguments shown in \usage documented in \arguments?) and
        ## aliases (do all functions shown in \usage have an alias?)
        if (dir.exists("man") && !extra_arch) {
            checkingLog(Log, "Rd \\usage sections")

            msg_doc_files <-
                c("Functions with \\usage entries",
                  "need to have the appropriate \\alias entries,",
                  "and all their arguments documented.\n",
                  "The \\usage entries must correspond to syntactically",
                  "valid R code.\n")
            any <- FALSE
            Rcmd <- paste("options(warn=1)\n",
                          if (do_install)
                          sprintf("tools::checkDocFiles(package = \"%s\")\n", pkgname)
                          else
                          sprintf("tools::checkDocFiles(dir = \"%s\")\n", pkgdir))
            out <- R_runR2(Rcmd)
            if (length(out)) {
                any <- TRUE
                warningLog(Log)
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
                wrapLog(msg_doc_files)
                wrapLog(msg_writing_Rd)
            }

            if (R_check_Rd_style && haveR) {
                msg_doc_style <-
                    c("The \\usage entries for S3 methods should use",
                      "the \\method markup and not their full name.\n")

                Rcmd <- paste("options(warn=1)\n",
                              if (do_install)
                              sprintf("tools::checkDocStyle(package = \"%s\")\n", pkgname)
                              else
                              sprintf("tools::checkDocStyle(dir = \"%s\")\n", pkgdir))
                out <- R_runR2(Rcmd)
                if (length(out)) {
                    if (!any) noteLog(Log)
                    any <- TRUE
                    printLog0(Log, paste(c(out, ""), collapse = "\n"))
                    wrapLog(msg_doc_style)
                    wrapLog(msg_writing_Rd)
                }
            }

            if (!any) resultLog(Log, "OK")
        }

        ## Check Rd contents
        if (dir.exists("man") && R_check_Rd_contents && !extra_arch) {
            checkingLog(Log, "Rd contents")
            Rcmd <- paste("options(warn=1)\n",
                          if (do_install)
                          sprintf("tools:::.check_Rd_contents(package = \"%s\")\n", pkgname)
                          else
                          sprintf("tools:::.check_Rd_contents(dir = \"%s\")\n", pkgdir))
            out <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=NULL")
            if (length(out)) {
                warningLog(Log)
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
            } else resultLog(Log, "OK")
        }

        ## Check undeclared dependencies in examples (if any)
        if (dir.exists("man") && do_install && !extra_arch && !is_base_pkg) {
            checkingLog(Log, "for unstated dependencies in examples")
            Rcmd <- paste("options(warn=1, showErrorCalls=FALSE)\n",
                          sprintf("tools:::.check_packages_used_in_examples(package = \"%s\")\n", pkgname))

            out <- R_runR2(Rcmd, "R_DEFAULT_PACKAGES=NULL")
            if (length(out)) {
                warningLog(Log)
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
                # wrapLog(msg_DESCRIPTION)
            } else resultLog(Log, "OK")
        } ## FIXME, what if no install?
    }

    check_data <- function()
    {
        ## Check contents of 'data'
        if (!is_base_pkg && dir.exists("data")) {
            checkingLog(Log, "contents of 'data' directory")
            fi <- list.files("data")
            if (!any(grepl("\\.[Rr]$", fi))) { # code files can do anything
                dataFiles <- basename(list_files_with_type("data", "data"))
                odd <- fi[! fi %in% c(dataFiles, "datalist")]
                if (length(odd)) {
                    warningLog(Log)
                    msg <-
                        c(sprintf("Files not of a type allowed in a %s directory:\n",
                                  sQuote("data")),
                          paste0(.pretty_format(odd), "\n"),
                          sprintf("Please use e.g. %s for non-R data files\n",
                                  sQuote("inst/extdata")))
                    printLog0(Log, msg)
                } else resultLog(Log, "OK")
            } else resultLog(Log, "OK")
        }

        ## Check for non-ASCII characters in 'data'
        if (!is_base_pkg && R_check_ascii_data && dir.exists("data")) {
            checkingLog(Log, "data for non-ASCII characters")
            out <- R_runR("tools:::.check_package_datasets('.')", R_opts2)
            out <- grep("Loading required package", out,
                        invert = TRUE, value = TRUE)
            out <- grep("Warning: changing locked binding", out,
                        invert = TRUE, value = TRUE, fixed = TRUE)
           if (length(out)) {
                bad <- grep("^Warning:", out)
                if (length(bad)) warningLog(Log) else noteLog(Log)
                printLog0(Log, .format_lines_with_indent(out), "\n")
            } else resultLog(Log, "OK")
        }

        ## Check for ASCII and uncompressed/unoptimized saves in 'data'
        if (!is_base_pkg && R_check_compact_data && dir.exists("data")) {
            checkingLog(Log, "data for ASCII and uncompressed saves")
            out <- R_runR("tools:::.check_package_compact_datasets('.', TRUE)",
                          R_opts2)
            out <- grep("Warning: changing locked binding", out,
                        invert = TRUE, value = TRUE, fixed = TRUE)
            if (length(out)) {
                warningLog(Log)
                printLog0(Log, .format_lines_with_indent(out), "\n")
            } else resultLog(Log, "OK")
        }

        ## Check for ASCII and uncompressed/unoptimized saves in 'sysdata':
        ## no base package has this
        if (R_check_compact_data && file.exists(file.path("R", "sysdata.rda"))) {
            checkingLog(Log, "R/sysdata.rda")
            out <- R_runR("tools:::.check_package_compact_sysdata('.', TRUE)",
                          R_opts2)
            if (length(out)) {
                bad <- grep("^Warning:", out)
                if (length(bad)) warningLog(Log) else noteLog(Log)
                printLog0(Log, .format_lines_with_indent(out), "\n")
            } else resultLog(Log, "OK")
        }
   }

    check_doc_contents <- function()
    {
        ## Have already checked that inst/doc exists
        doc_dir <- file.path(libdir, pkgname, "doc")
        if (!dir.exists(doc_dir)) return()
        checkingLog(Log, "installed files from 'inst/doc'")
        ## special case common problems.
        any <- FALSE
        files <- dir(file.path(pkgdir, "inst", "doc"))
        already <- c("jss.cls", "jss.bst", "Rd.sty", "Sweave.sty")
        bad <- files[files %in% already]
        if (length(bad)) {
            noteLog(Log)
            any <- TRUE
            printLog0(Log,
                      "The following files are already in R: ",
                      paste(sQuote(bad), collapse = ", "), "\n",
                      "Please remove them from your package.\n")
        }
        files2 <- dir(file.path(pkgdir, "inst", "doc"), recursive = TRUE,
                     pattern = "[.](cls|sty|drv)$", full.names = TRUE)
        ## Skip Rnews.sty and RJournal.sty for now
        files2 <- files2[! basename(files2) %in%
                       c("jss.cls", "jss.drv", "Rnews.sty", "RJournal.sty")]
        bad <- character()
        for(f in files2) {
            pat <- "%% (This generated file may be distributed as long as the|original source files, as listed above, are part of the|same distribution.)"
            if(length(grep(pat, readLines(f, warn = FALSE), useBytes = TRUE))
               == 3L) bad <- c(bad, basename(f))
        }
        if (length(bad)) {
            if(!any) noteLog(Log)
            any <- TRUE
            printLog0(Log,
                      "The following files contain a license that requires\n",
                      "distribution of original sources:\n",
                      "  ", paste(sQuote(bad), collapse = ", "), "\n",
                      "Please ensure that you have complied with it.\n")
        }

        ## Now look for TeX leftovers (and soiltexture, Amelia ...).
        bad <- grepl("[.](log|aux|bbl|blg|dvi|toc|out|Rd|Rout|dbj|drv|ins)$",
                     files, ignore.case = TRUE)
        if (any(bad)) {
            if(!any) noteLog(Log)
            any <- TRUE
            printLog0(Log,
                      "The following files look like leftovers/mistakes:\n",
                      paste(strwrap(paste(sQuote(files[bad]), collapse = ", "),
                                    indent = 2, exdent = 2), collapse = "\n"),
                      "\nPlease remove them from your package.\n")
        }

        files <- dir(doc_dir)
        files <- files[! files %in% already]
        bad <- grepl("[.](tex|lyx|png|jpg|jpeg|gif|ico|bst|cls|sty|ps|eps|img)$",
                     files, ignore.case = TRUE)
        bad <- bad | grepl("(Makefile|~$)", files)
        ## How about any pdf files which look like figures files from vignettes?
        vigns <- pkgVignettes(dir = pkgdir)
        if (!is.null(vigns) && length(vigns$docs)) {
            vf <- vigns$names
            pat <- paste(vf, collapse="|")
            pat <- paste0("^(", pat, ")-[0-9]+[.]pdf")
            bad <- bad | grepl(pat, files)
        }
        bad <- bad | grepl("^fig.*[.]pdf$", files)
        badf <- files[bad]
        dirs <- basename(list.dirs(doc_dir, recursive = FALSE))
        badd <- dirs[dirs %in% c("auto", "Bilder", "fig", "figs", "figures",
                                 "Figures", "img", "images", "JSSstyle",
                                 "jssStyle", "screenshots2", "src", "tex", "tmp")]
        if (length(c(badf, badd))) {
            if(!any) noteLog(Log)
            any <- TRUE
            if(length(badf))
                printLog0(Log,
                          "The following files should probably not be installed:\n",
                          paste(strwrap(paste(sQuote(badf), collapse = ", "),
                                        indent = 2, exdent = 2), collapse = "\n"),
                          "\n")
            if(length(badd))
                printLog0(Log,
                          "The following directories should probably not be installed:\n",
                          paste(strwrap(paste(sQuote(badd), collapse = ", "),
                                        indent = 2, exdent = 2), collapse = "\n"),
                          "\n")
            printLog0(Log, "\nConsider the use of a .Rinstignore file: see ",
                      sQuote("Writing R Extensions"), ",\n",
                      "or move the vignette sources from ",
                      sQuote("inst/doc"), " to ", sQuote("vignettes"), ".\n")
        }
        if (!any) resultLog(Log, "OK")
    }

    check_vign_contents <- function()
    {
        checkingLog(Log, "files in 'vignettes'")
        ## special case common problems.
        any <- FALSE
        pattern <- vignetteEngine("Sweave")$pattern
        vign_dir <- file.path(pkgdir, "vignettes")
        sources <- setdiff(list.files(file.path(pkgdir, "inst", "doc"),
                                      pattern = pattern),
                           list.files(vign_dir, pattern = pattern))
        if(length(sources)) {
            warningLog(Log)
            any <- TRUE
            msg <- c("Vignette sources in 'inst/doc' missing from the 'vignettes' directory:",
                    strwrap(paste(sQuote(sources), collapse = ", "),
                            indent = 2L, exdent = 4L),
                     "")
            printLog0(Log, paste(msg, collapse = "\n"))
        }

        files <- dir(file.path(pkgdir, "vignettes"))
        already <- c("jss.cls", "jss.bst", "Rd.sty", "Sweave.sty")
        bad <- files[files %in% already]
        if (length(bad)) {
            noteLog(Log)
            any <- TRUE
            printLog0(Log,
                      "The following files are already in R: ",
                      paste(sQuote(bad), collapse = ", "), "\n",
                      "Please remove them from your package.\n")
        }
        files2 <- dir(file.path(pkgdir, "vignettes"), recursive = TRUE,
                     pattern = "[.](cls|sty|drv)$", full.names = TRUE)
        files2 <- files2[! basename(files2) %in%
                       c("jss.cls", "jss.drv", "Rnews.sty", "RJournal.sty")]
        bad <- character()
        for(f in files2) {
            pat <- "%% (This generated file may be distributed as long as the|original source files, as listed above, are part of the|same distribution.)"
            if(length(grep(pat, readLines(f, warn = FALSE), useBytes = TRUE))
               == 3L) bad <- c(bad, basename(f))
        }
        if (length(bad)) {
            if(!any) noteLog(Log)
            any <- TRUE
            printLog0(Log,
                      "The following files contain a license that requires\n",
                      "distribution of original sources:\n",
                      "  ", paste(sQuote(bad), collapse = ", "), "\n",
                      "Please ensure that you have complied with it.\n")
        }

        ## Now look for TeX leftovers (and soiltexture, Amelia ...).
        bad <- grepl("[.](log|aux|bbl|blg|dvi|toc|out|Rd|Rout|dbj|drv|ins)$",
                     files, ignore.case = TRUE)
        if (any(bad)) {
            if(!any) noteLog(Log)
            any <- TRUE
            printLog0(Log,
                      "The following files look like leftovers/mistakes:\n",
                      paste(strwrap(paste(sQuote(files[bad]), collapse = ", "),
                                    indent = 2, exdent = 2), collapse = "\n"),
                      "\nPlease remove them from your package.\n")
        }
        if (!any) resultLog(Log, "OK")
    }

    check_doc_size <- function()
    {
        ## Have already checked that inst/doc exists and qpdf can be found
        pdfs <- dir('inst/doc', pattern="\\.pdf",
                    recursive = TRUE, full.names = TRUE)
        pdfs <- setdiff(pdfs, "inst/doc/Rplots.pdf")
        if (length(pdfs)) {
            checkingLog(Log, "sizes of PDF files under 'inst/doc'")
            any <- FALSE
            td <- tempfile('pdf')
            dir.create(td)
            file.copy(pdfs, td)
            res <- compactPDF(td, gs_quality = "none") # use qpdf
            res <- format(res, diff = 1e5)
            if(length(res)) {
                noteLog(Log)
                any <- TRUE
                printLog(Log,
                         "  'qpdf' made some significant size reductions:\n",
                         paste("  ", res, collapse = "\n"),
                         "\n",
                         "  consider running tools::compactPDF() on these files\n")
            }
            if (R_check_doc_sizes2) {
                gs_cmd <- find_gs_cmd()
                if (nzchar(gs_cmd)) {
                    res <- compactPDF(td, gs_cmd = gs_cmd, gs_quality = "ebook")
                    res <- format(res, diff = 2.56e5) # 250 KB for now
                    if(length(res)) {
                        if (!any) warningLog(Log)
                        any <- TRUE
                        printLog(Log,
                                 "  'gs+qpdf' made some significant size reductions:\n",
                                 paste("  ", res, collapse = "\n"),
                                 "\n",
                                 '  consider running tools::compactPDF(gs_quality = "ebook") on these files\n')
                    }
                } else {
                    if (!any) noteLog(Log)
                    any <- TRUE
                    printLog(Log, "Unable to find GhostScript executable to run checks on size reduction\n")
                }

            }
            if (!any) resultLog(Log, "OK")
        }
    }

    check_src_dir <- function()
    {
        ## Check C/C++/Fortran sources/headers for CRLF line endings.
        ## <FIXME>
        ## Does ISO C really require LF line endings?  (Reference?)
        ## We know that some versions of Solaris cc and f77/f95
        ## will not accept CRLF or CR line endings.
        ## (Sun Studio 12 definitely objects to CR in both C and Fortran).
        ## </FIXME>
        checkingLog(Log, "line endings in C/C++/Fortran sources/headers")
        ## pattern is "([cfh]|cc|cpp)"
        files <- dir("src", pattern = "\\.([cfh]|cc|cpp)$",
                     full.names = TRUE, recursive = TRUE)
        ## exclude dirs starting src/win, e.g for tiff
        files <- grep("^src/[Ww]in", files, invert = TRUE, value = TRUE)
        bad_files <- character()
        for(f in files) {
            contents <- readChar(f, file.info(f)$size, useBytes = TRUE)
            if (grepl("\r", contents, fixed = TRUE, useBytes = TRUE))
                bad_files <- c(bad_files, f)
        }
        if (length(bad_files)) {
            warningLog(Log, "Found the following sources/headers with CR or CRLF line endings:")
            printLog0(Log, .format_lines_with_indent(bad_files), "\n")
            printLog(Log, "Some Unix compilers require LF line endings.\n")
        } else resultLog(Log, "OK")

        ## Check src/Make* for LF line endings, as Sun make does not accept CRLF
        checkingLog(Log, "line endings in Makefiles")
        bad_files <- character()
        ## .win files are not checked, as CR/CRLF work there
        all_files <-
            dir("src",
                pattern = "^(Makevars|Makevars.in|Makefile|Makefile.in)$",
                full.names = TRUE, recursive = TRUE)
        for(f in all_files) {
            if (!file.exists(f)) next
            contents <- readChar(f, file.info(f)$size, useBytes = TRUE)
            if (grepl("\r", contents, fixed = TRUE, useBytes = TRUE))
                bad_files <- c(bad_files, f)
        }
        if (length(bad_files)) {
            warningLog(Log, "Found the following Makefiles with CR or CRLF line endings:")
            printLog0(Log, .format_lines_with_indent(bad_files), "\n")
            printLog(Log, "Some Unix 'make' programs require LF line endings.\n")
        } else resultLog(Log, "OK")

        ## Check src/Makevars[.in] compilation flags.
        if (length(makevars)) {
            checkingLog(Log, "compilation flags in Makevars")

            Rcmd <- sprintf("tools:::.check_make_vars(\"src\", %s)\n",
                            deparse(makevars))
            out <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=NULL")
            if (length(out)) {
                if(any(grepl("^(Non-portable flags|Variables overriding)", out)))
                   warningLog(Log) else noteLog(Log)
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
            } else resultLog(Log, "OK")
        }

        ## check src/Makevar*, src/Makefile* for correct use of BLAS_LIBS
        ## FLIBS is not needed on Windows, at least currently (as it is
        ## statically linked).
        checkingLog(Log, "for portable use of $(BLAS_LIBS) and $(LAPACK_LIBS)")
        makefiles <- Sys.glob(file.path("src",
                                        c("Makevars", "Makevars.in",
                                          "Makefile", "Makefile.win")))
        any <- FALSE
        for (f in makefiles) {
            lines <- readLines(f, warn = FALSE)
            ## Combine lines ending in escaped newlines.
            if(any(ind <- grepl("[\\]$", lines, useBytes = TRUE))) {
                ## Eliminate escape.
                lines[ind] <-
                    sub("[\\]$", "", lines[ind], useBytes = TRUE)
                ## Determine ids of blocks that need to be joined.
                ind <- seq_along(ind) - c(0, cumsum(ind)[-length(ind)])
                ## And join.
                lines <- unlist(lapply(split(lines, ind), paste,
                                       collapse = " "))
            }
            c1 <- grepl("^[[:space:]]*PKG_LIBS", lines, useBytes = TRUE)
            c2l <- grepl("\\$[{(]{0,1}LAPACK_LIBS", lines, useBytes = TRUE)
            c2b <- grepl("\\$[{(]{0,1}BLAS_LIBS", lines, useBytes = TRUE)
            c3 <- grepl("\\$[{(]{0,1}FLIBS", lines, useBytes = TRUE)
            if (any(c1 & c2l & !c2b)) {
                if (!any) warningLog(Log)
                any <- TRUE
                printLog(Log,
                         "  apparently using $(LAPACK_LIBS) without $(BLAS_LIBS) in ",
                         sQuote(f), "\n")
            }
            if (any(c1 & (c2b | c2l) & !c3)) {
                if (!any) warningLog(Log)
                any <- TRUE
                printLog(Log, "  apparently PKG_LIBS is missing $(FLIBS) in ",
                         sQuote(f), "\n")
            }
        }
        if (!any) resultLog(Log, "OK")
    }

    check_sos <- function() {
        checkingLog(Log, "compiled code")
        ## from sotools.R
        Rcmd <- paste("options(warn=1)\n",
                      sprintf("tools:::check_compiled_code(\"%s\")",
                              file.path(libdir, pkgname)))
        out <- R_runR(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=NULL")
        if(length(out) == 1L && grepl("^Note:", out)) {
            ## This will be a note about symbols.rds not being available
            if(!is_base_pkg) {
                noteLog(Log)
                printLog0(Log, c(out, "\n"))
            } else resultLog(Log, "OK")
        } else if(length(out)) {
            ## If we have named objects then we have symbols.rds and
            ## will not be picking up symbols just in system libraries.
            haveObjs <- any(grepl("^ *Object", out))
            if(haveObjs && any(grepl("(abort|assert|exit)", out)) &&
               !pkgname %in% c("multicore", "parallel")) # these need to call exit
                warningLog(Log)
            else noteLog(Log)
            printLog0(Log, paste(c(out, ""), collapse = "\n"))
            nAPIs <- length(grep("Found non-API", out))
            nBad <- length(grep(", possibly from ", out))
            msg <- if (nBad) {
                if(haveObjs)
                    c("Compiled code should not call entry points which",
                      "might terminate R nor write to stdout/stderr instead",
                      "of to the console.\n")
                else
                    c("Compiled code should not call entry points which",
                      "might terminate R nor write to stdout/stderr instead",
                      "of to the console.  The detected symbols are linked",
                      "into the code but might come from libraries",
                      "and not actually be called.\n")
            } else character()
            if(nAPIs)
                msg <- c(msg,
                         "Compiled code should not call non-API entry points in R.\n")
            wrapLog("\n", paste(msg, collapse = " "), "\n",
                    "See 'Writing portable packages'",
                    "in the 'Writing R Extensions' manual.\n")
        } else resultLog(Log, "OK")
    }

    check_loading <- function(arch = "")
    {
        checkingLog(Log, "whether the package can be loaded")
        Rcmd <- sprintf("library(%s)", pkgname)
        opts <- if(nzchar(arch)) R_opts4 else R_opts2
        env <- "R_DEFAULT_PACKAGES=NULL"
        env1 <- if(nzchar(arch)) env0 else character()
        out <- R_runR(Rcmd, opts, env1, arch = arch)
        if(length(st <- attr(out, "status"))) {
            errorLog(Log)
            wrapLog("Loading this package had a fatal error",
                    "status code ", st,  "\n")
            if(length(out))
                printLog0(Log,
                          paste(c("Loading log:", out, ""),
                                collapse = "\n"))
            do_exit()
        }
        if (any(grepl("^Error", out))) {
            errorLog(Log)
            printLog0(Log, paste(c(out, ""), collapse = "\n"))
            wrapLog("\nIt looks like this package",
                    "has a loading problem: see the messages",
                    "for details.\n")
            do_exit()
        } else resultLog(Log, "OK")

        checkingLog(Log, "whether the package can be loaded with stated dependencies")
        out <- R_runR(Rcmd, opts, c(env, env1), arch = arch)
        if (any(grepl("^Error", out)) || length(attr(out, "status"))) {
            warningLog(Log)
            printLog0(Log, paste(c(out, ""), collapse = "\n"))
            wrapLog("\nIt looks like this package",
                    "(or one of its dependent packages)",
                    "has an unstated dependence on a standard",
                    "package.  All dependencies must be",
                    "declared in DESCRIPTION.\n")
            wrapLog(msg_DESCRIPTION)
        } else resultLog(Log, "OK")

        checkingLog(Log, "whether the package can be unloaded cleanly")
        Rcmd <- sprintf("suppressMessages(library(%s)); cat('\n---- unloading\n'); detach(\"package:%s\")", pkgname, pkgname)
        out <- R_runR(Rcmd, opts, c(env, env1), arch = arch)
        if (any(grepl("^(Error|\\.Last\\.lib failed)", out)) ||
            length(attr(out, "status"))) {
            warningLog(Log)
            ll <- grep("---- unloading", out)
            if(length(ll)) {
                ll <- ll[length(ll)]
                out <- out[ll:length(out)]
            }
            printLog0(Log, paste(c(out, ""), collapse = "\n"))
        } else resultLog(Log, "OK")

        ## and if it has a namespace, that we can load/unload just
        ## the namespace
        if (file.exists(file.path(pkgdir, "NAMESPACE"))) {
            checkingLog(Log, "whether the namespace can be loaded with stated dependencies")
            Rcmd <- sprintf("loadNamespace(\"%s\")", pkgname)
            out <- R_runR(Rcmd, opts, c(env, env1), arch = arch)
            if (any(grepl("^Error", out)) || length(attr(out, "status"))) {
                warningLog(Log)
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
                wrapLog("\nA namespace must be able to be loaded",
                        "with just the base namespace loaded:",
                        "otherwise if the namespace gets loaded by a",
                        "saved object, the session will be unable",
                        "to start.\n\n",
                        "Probably some imports need to be declared",
                        "in the NAMESPACE file.\n")
            } else resultLog(Log, "OK")

            checkingLog(Log,
                        "whether the namespace can be unloaded cleanly")
            Rcmd <- sprintf("invisible(suppressMessages(loadNamespace(\"%s\"))); cat('\n---- unloading\n'); unloadNamespace(\"%s\")",
                            pkgname, pkgname)
            out <- if (is_base_pkg && pkgname != "stats4")
                R_runR(Rcmd, opts, "R_DEFAULT_PACKAGES=NULL", arch = arch)
            else R_runR(Rcmd, opts, env1)
            if (any(grepl("^(Error|\\.onUnload failed)", out)) ||
                length(attr(out, "status"))) {
                warningLog(Log)
                ll <- grep("---- unloading", out)
                if(length(ll)) {
                    ll <- ll[length(ll)]
                    out <- out[ll:length(out)]
                }
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
            } else resultLog(Log, "OK")
        }

        ## No point in this test if already installed in .Library
        if (!pkgname %in% dir(.Library)) {
            checkingLog(Log, "loading without being on the library search path")
            Rcmd <- sprintf("library(%s, lib.loc = '%s')", pkgname, libdir)
            opts <- if(nzchar(arch)) R_opts4 else R_opts2
            env <- setRlibs(pkgdir = pkgdir, libdir = libdir,
                            self2 = FALSE, quote = TRUE)
            if(nzchar(arch)) env <- c(env, "R_DEFAULT_PACKAGES=NULL")
            out <- R_runR(Rcmd, opts, env, arch = arch)
            if (any(grepl("^Error", out))) {
                warningLog(Log)
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
                wrapLog("\nIt looks like this package",
                        "has a loading problem when not on .libPaths:",
                        "see the messages for details.\n")
            } else resultLog(Log, "OK")
        }
    }

    run_examples <- function()
    {
        run_one_arch <- function(exfile, exout, arch = "")
        {
            any <- FALSE
            ## moved here to avoid WARNING + OK
            if (nzchar(enc) && is_ascii) {
                warningLog(Log,
                           paste("checking a package with encoding ",
                                 sQuote(e), " in an ASCII locale\n"))
                any <- TRUE
            }
            Ropts <- if (nzchar(arch)) R_opts3 else R_opts
            if (use_valgrind) Ropts <- paste(Ropts, "-d valgrind")
            t1 <- proc.time()
            ## might be diff-ing results against tests/Examples later
            ## so force LANGUAGE=en
            status <- R_runR(NULL, c(Ropts, enc),
                             c("LANGUAGE=en", "_R_CHECK_INTERNALS2_=1",
                               if(nzchar(arch)) env0,
                               jitstr, elibs),
                             stdout = exout, stderr = exout,
                             stdin = exfile, arch = arch)
            t2 <- proc.time()
            if (status) {
                errorLog(Log, "Running examples in ",
                         sQuote(basename(exfile)),
                         " failed")
                ## Try to spot the offending example right away.
                txt <- paste(readLines(exout, warn = FALSE),
                             collapse = "\n")
                ## Look for the header section anchored by a
                ## subsequent call to flush(): needs to be kept in
                ## sync with the code in massageExamples (in
                ## testing.R).  Should perhaps also be more
                ## defensive about the prompt ...
                chunks <- strsplit(txt,
                                   "> ### \\* [^\n]+\n> \n> flush[^\n]+\n> \n", useBytes = TRUE)[[1L]]
                                       if((ll <- length(chunks)) >= 2) {
                                           printLog(Log,
                                                    "The error most likely occurred in:\n\n")
                                           printLog0(Log, chunks[ll], "\n")
                                       } else {
                                           ## most likely error before the first example
                                           ## so show all the output.
                                           printLog(Log, "The error occurred in:\n\n")
                                           printLog0(Log, txt, "\n")
                                       }
                return(FALSE)
            }

            print_time(t1, t2, Log)
            ## Look at the output from running the examples.  For
            ## the time being, report warnings about use of
            ## deprecated , as the next release will make
            ## them defunct and hence using them an error.
            bad <- FALSE
            lines <- readLines(exout, warn = FALSE)
            bad_lines <- grep("^Warning: .*is deprecated.$",
                              lines, useBytes = TRUE, value = TRUE)
            if(length(bad_lines)) {
                bad <- TRUE
                warningLog(Log, "Found the following significant warnings:\n")
                printLog0(Log, .format_lines_with_indent(bad_lines), "\n")
                wrapLog("Deprecated functions may be defunct as",
                        "soon as of the next release of R.\n",
                        "See ?Deprecated.\n")
            }
            bad_lines <- grep("^Warning.*screen devices should not be used in examples",
                              lines, useBytes = TRUE, value = TRUE)

            if(length(bad_lines)) {
                if(!bad) {
                    warningLog(Log,
                               "Found the following significant warnings:")
                    bad <- TRUE
                }
                printLog0(Log, .format_lines_with_indent(bad_lines), "\n")
                wrapLog("dev.new() is the preferred way to open a new device,",
                        "in the unlikely event one is needed.")
            }
            bad_lines <- grep("^Warning: .*simultaneous processes spawned$",
                              lines, useBytes = TRUE, value = TRUE)
            if(length(bad_lines)) {
                if(!bad) {
                    warningLog(Log,
                               "Found the following significant warnings:")
                    bad <- TRUE
                }
                printLog0(Log, .format_lines_with_indent(bad_lines), "\n")
                wrapLog("Note that CRAN packages must never use more than two",
                        "cores simultaneously during their checks.")
            }
            any <- any || bad
            if (!any) resultLog(Log, "OK")

            ## Try to compare results from running the examples to
            ## a saved previous version.
            exsave <- file.path(pkgdir, "tests", "Examples",
                                paste0(pkgname, "-Ex.Rout.save"))
            if (file.exists(exsave)) {
                checkingLog(Log, "differences from ",
                            sQuote(basename(exout)),
                            " to ", sQuote(basename(exsave)))
                cmd <- paste0("invisible(tools::Rdiff('",
                              exout, "', '", exsave, "',TRUE,TRUE))")
                out <- R_runR(cmd, R_opts2)
                if(length(out))
                    printLog0(Log, paste(c("", out, ""), collapse = "\n"))
                resultLog(Log, "OK")
            }
            if (do_timings) {
                tfile <- paste0(pkgname, "-Ex.timings")
                times <- read.table(tfile, header = TRUE, row.names = 1L, colClasses = c("character", rep("numeric", 3)))
                o <- order(times[[1]]+times[[2]], decreasing = TRUE)
                times <- times[o, ]
                keep <- (times[[1]] + times[[2]] > 5) | (times[[3]] > 5)
                if(any(keep)) {
                    printLog(Log, "Examples with CPU or elapsed time > 5s\n")
                    times <- capture.output(format(times[keep, ]))
                    printLog0(Log, paste(times, collapse = "\n"), "\n")
                }
            }
            TRUE
        }

        checkingLog(Log, "examples")
        if (!do_examples) resultLog(Log, "SKIPPED")
        else {
            pkgtopdir <- file.path(libdir, pkgname)
            cmd <- sprintf('tools:::.createExdotR("%s", "%s", silent = TRUE, use_gct = %s, addTiming = %s)', pkgname, pkgtopdir, use_gct, do_timings)
            Rout <- tempfile("Rout")
            ## any arch will do here
            status <- R_runR(cmd, R_opts2, "LC_ALL=C",
                             stdout = Rout, stderr = Rout)
            if (status) {
                errorLog(Log,
                         paste("Running massageExamples to create",
                               sQuote(exfile), "failed"))
                printLog0(Log,
                          paste(readLines(Rout, warn = FALSE),
                                collapse = "\n"),
                          "\n")
                do_exit(1L)
            }
            ## It ran, but did it create any examples?
            exfile <- paste0(pkgname, "-Ex.R")
            if (file.exists(exfile)) {
                enc <- if (!is.na(e <- desc["Encoding"])) {
                    paste("--encoding", e, sep="=")
                } else ""
                if (!this_multiarch) {
                    exout <- paste0(pkgname, "-Ex.Rout")
                    if(!run_one_arch(exfile, exout)) do_exit(1L)
                } else {
                    printLog(Log, "\n")
                    Log$stars <<-  "**"
                    res <- TRUE
                    for (arch in inst_archs) {
                        printLog(Log, "** running examples for arch ",
                                 sQuote(arch), " ...")
                        if (arch %in% R_check_skip_examples_arch) {
                            resultLog(Log, "SKIPPED")
                        } else {
                            tdir <- paste0("examples_", arch)
                            dir.create(tdir)
                            if (!dir.exists(tdir)) {
                                errorLog(Log,
                                         "unable to create examples directory")
                                do_exit(1L)
                            }
                            od <- setwd(tdir)
                            exout <- paste0(pkgname, "-Ex_", arch, ".Rout")
                            res <- res & run_one_arch(file.path("..", exfile),
                                                      file.path("..", exout),
                                                      arch)
                            setwd(od)
                        }
                    }
                    Log$stars <<-  "*"
                    if (!res) do_exit(1L)
                }
            } else {
                resultLog(Log, "NONE")
                no_examples <<- TRUE
            }
        }
    }

    run_tests <- function()
    {
        if (!extra_arch && !is_base_pkg) {
            checkingLog(Log, "for unstated dependencies in tests")
            Rcmd <- paste("options(warn=1, showErrorCalls=FALSE)\n",
                          sprintf("tools:::.check_packages_used_in_tests(\"%s\")\n", pkgdir))

            out <- R_runR2(Rcmd, "R_DEFAULT_PACKAGES=NULL")
            if (length(out)) {
                warningLog(Log)
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
                # wrapLog(msg_DESCRIPTION)
            } else resultLog(Log, "OK")
        }

        checkingLog(Log, "tests")
        run_one_arch <- function(arch = "")
        {
            testsrcdir <- file.path(pkgdir, "tests")
            testdir <- file.path(pkgoutdir, "tests")
            if(nzchar(arch)) testdir <- paste(testdir, arch, sep = "_")
            if(!dir.exists(testdir)) dir.create(testdir, mode = "0755")
            if(!dir.exists(testdir)) {
                errorLog(Log,
                         sprintf("unable to create %s", sQuote(testdir)))
                do_exit(1L)
            }
            file.copy(Sys.glob(paste0(testsrcdir, "/*")),
                      testdir, recursive = TRUE)
            setwd(testdir)
            extra <- character()
            if (use_gct) extra <- c(extra, "use_gct = TRUE")
            if (use_valgrind) extra <- c(extra, "use_valgrind = TRUE")
            tf <- gsub("\\", "/", tempfile(), fixed=TRUE)
            extra <- c(extra, paste0('Log="', tf, '"'))
            ## might be diff-ing results against tests/*.R.out.save
            ## so force LANGUAGE=en
            cmd <- paste0("tools:::.runPackageTestsR(",
                         paste(extra, collapse = ", "), ")")
            t1 <- proc.time()
            status <- R_runR(cmd,
                             if(nzchar(arch)) R_opts4 else R_opts2,
                             env = c("LANGUAGE=en",
                             "_R_CHECK_INTERNALS2_=1",
                             if(nzchar(arch)) env0,
                             jitstr, elibs),
                             stdout = "", stderr = "", arch = arch)
            t2 <- proc.time()
            if (status) {
                errorLog(Log)
                ## Don't just fail: try to log where the problem occurred.
                ## First, find the test which failed.
                ## (Maybe there was an error without a failing test.)
                bad_files <- dir(".", pattern="\\.Rout\\.fail")
                if (length(bad_files)) {
                    ## Read in output from the (first) failed test
                    ## and retain at most the last 13 lines
                    ## (13? why not?).
                    file <- bad_files[1L]
                    lines <- readLines(file, warn = FALSE)
                    file <- file.path("tests", sub("out\\.fail", "", file))
                    ll <- length(lines)
                    lines <- lines[max(1, ll-12):ll]
                    if (R_check_suppress_RandR_message)
                        lines <- grep('^Xlib: *extension "RANDR" missing on display',
                                      lines, invert = TRUE, value = TRUE)
                    printLog(Log, sprintf("Running the tests in %s failed.\n", sQuote(file)))
                    printLog(Log, "Last 13 lines of output:\n")
                    printLog0(Log, .format_lines_with_indent(lines), "\n")
                }
                return(FALSE)
            } else {
                print_time(t1, t2, Log)
                resultLog(Log, "OK")
                if (Log$con > 0L && file.exists(tf)) {
                    ## write results only to 00check.log
                    lines <- readLines(tf, warn = FALSE)
                    cat(lines, sep="\n", file = Log$con)
                    unlink(tf)
                }
            }
            setwd(pkgoutdir)
            TRUE
        }
        if (do_install && do_tests) {
            if (!this_multiarch) {
                res <- run_one_arch()
            } else {
                printLog(Log, "\n")
                res <- TRUE
                for (arch in inst_archs)
                    if (!(arch %in% R_check_skip_tests_arch)) {
                        printLog(Log, "** running tests for arch ",
                                 sQuote(arch), " ...")
                        res <- res & run_one_arch(arch)
                    }
            }
            if (!res) do_exit(1L)
        } else resultLog(Log, "SKIPPED")
    }

    run_vignettes <- function(desc)
    {
        vigns <- pkgVignettes(dir = pkgdir)
        if (is.null(vigns) || !length(vigns$docs)) return()

        if(do_install && !spec_install && !is_base_pkg && !extra_arch) {
            ## fake installs don't install inst/doc
            checkingLog(Log, "for unstated dependencies in vignettes")
            Rcmd <- paste("options(warn=1, showErrorCalls=FALSE)\n",
                          sprintf("tools:::.check_packages_used_in_vignettes(package = \"%s\")\n", pkgname))
            out <- R_runR2(Rcmd, "R_DEFAULT_PACKAGES=NULL")
            if (length(out)) {
                noteLog(Log)
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
            } else resultLog(Log, "OK")
        }

        checkingLog(Log, "package vignettes in ", sQuote("inst/doc"))
        any <- FALSE
        ## Do PDFs or HTML files exist for all package vignettes?
        ## A base source package need not have PDFs to avoid
        ## frequently-changing binary files in the SVN archive.
        if (!is_base_pkg) {
            dir <- file.path(pkgdir, "inst", "doc")
            outputs <- character(length(vigns$docs))
            for (i in seq_along(vigns$docs)) {
                file <- vigns$docs[i]
                name <- vigns$names[i]
                engine <- vignetteEngine(vigns$engines[i])
                outputs[i] <- tryCatch({
                    find_vignette_product(name, what="weave", final=TRUE, dir=dir, engine = engine)
                }, error = function(ex) NA)
            }
            bad_vignettes <- vigns$docs[is.na(outputs)]
            if (nb <- length(bad_vignettes)) {
                any <- TRUE
                warningLog(Log)
                msg <- ngettext(nb,
                                "Package vignette without corresponding PDF/HTML:\n",
                                "Package vignettes without corresponding PDF/HTML:\n", domain = NA)
                printLog0(Log, msg)
                printLog0(Log,
                          paste(c(paste("  ",
                                        sQuote(basename(bad_vignettes))),
                                  "", ""), collapse = "\n"))
            }
            encs <- vapply(vigns$docs, getVignetteEncoding, "")
            bad_vignettes <- vigns$docs[encs == "non-ASCII"]
            if(nb <- length(bad_vignettes)) {
                if(!any) warningLog(Log)
                any <- TRUE
                msg <- ngettext(nb,
                         "Non-ASCII package vignette without specified encoding:\n",
                         "Non-ASCII package vignettes without specified encoding:\n", domain = NA)
                printLog0(Log, "  ", msg)
                printLog0(Log,
                          paste(c(paste("  ",
                                        sQuote(basename(bad_vignettes))),
                                  "", ""), collapse = "\n"))
            }
        }

# FIXME:  we should do this check in build, not here.  Currently not doing it at all.
#        ## Do any of the .R files which will be generated
#        ## exist in inst/doc?  If so the latter will be ignored,
#        sources <-
#            basename(list_files_with_exts(file.path(pkgdir, "inst/doc"), "R"))
#        custom <- !is.na(desc["VignetteBuilder"])
#        if (length(sources) && !custom) {
#            new_sources <- paste0(vigns$names, ".R")
#            dups <- sources[sources %in% new_sources]
#            if(nb <- length(dups)) {
#                if(!any) warningLog(Log)
#                any <- TRUE
#                msg <- ngettext(nb,
#                                "Unused file in 'inst/doc' which is pointless or misleading",
#                                "Unused files in 'inst/doc' which are pointless or misleading", domain = NA)
#                printLog(Log, "  ",
#                         paste(msg,
#                               "  as they will be re-created from the vignettes:", "",
#                               sep = "\n"))
#                printLog(Log,
#                         paste(c(paste("  ", dups), "", ""),
#                               collapse = "\n"))
#            }
#        }
        ## avoid case-insensitive matching
        if ("makefile" %in% dir(vigns$dir)) {
            if(!any) warningLog(Log)
            any <- TRUE
            printLog(Log,
                     "  Found 'inst/doc/makefile': should be 'Makefile' and will be ignored\n")
        }
        if ("Makefile" %in% dir(vigns$dir)) {
            f <- file.path(vigns$dir, "Makefile")
            lines <- readLines(f, warn = FALSE)
            ## remove comment lines
            lines <- grep("^[[:space:]]*#", lines, invert = TRUE, value = TRUE)
            if(any(grepl("[^/]R +CMD", lines))) {
                if(!any) warningLog(Log)
                any <- TRUE
                printLog(Log,
                         "  Found 'R CMD' in Makefile: should be '\"$(R_HOME)/bin/R\" CMD'\n")
            }
            contents <- readChar(f, file.info(f)$size, useBytes = TRUE)
            if(any(grepl("\r", contents, fixed = TRUE, useBytes = TRUE))) {
                if(!any) warningLog(Log)
                any <- TRUE
                printLog(Log, "Found Makefile with CR or CRLF line endings:\n")
                printLog(Log, "some Unix 'make' programs require LF line endings.\n")
           }
            if(any(grepl("[^/]Rscript", lines))) {
                if(!any) warningLog(Log)
                any <- TRUE
                printLog(Log,
                         "  Found 'Rscript' in Makefile: should be '\"$(R_HOME)/bin/Rscript\"'\n")
            }
        }

        ## If the vignettes declare an encoding, are they actually in it?
        ## (We don't check the .tex, though)
        bad_vignettes <- character()
        for (v in vigns$docs) {
            enc <- getVignetteEncoding(v, TRUE)
            if (enc %in% c("", "non-ASCII", "unknown")) next
            lines <- readLines(v, warn = FALSE) # some miss final NA
            lines2 <- iconv(lines, enc, "UTF-16LE", toRaw = TRUE)
            if(any(vapply(lines2, is.null, TRUE)))
                bad_vignettes <- c(bad_vignettes, v)
            if(nb <- length(bad_vignettes)) {
                if(!any) warningLog(Log)
                any <- TRUE
                msg <- ngettext(nb,
                                "Package vignette which is not in its specified encoding:\n",
                                "Package vignettes which are not in their specified encoding:\n", domain = NA)
                printLog0(Log, "  ", msg)
                printLog0(Log,
                          paste(c(paste("  ",
                                        sQuote(basename(bad_vignettes))),
                                  "", ""), collapse = "\n"))
            }
        }

        if (!any) resultLog(Log, "OK")

        if (do_install && do_vignettes) {
            ## Can we run the code in the vignettes?
            ## Should checking the vignettes assume the system default
            ## packages, or just base?
            ## FIXME: should we do this for multiple sub-archs?

            checkingLog(Log, "running R code from vignettes")
            vigns <- pkgVignettes(dir = pkgdir)
            problems <- list()
            res <- character()
            cat("\n")
            def_enc <- desc["Encoding"]
            if( (is.na(def_enc))) def_enc <- ""
            t1 <- proc.time()
            for (i in seq_along(vigns$docs)) {
                file <- vigns$docs[i]
                name <- vigns$names[i]
                enc <- getVignetteEncoding(file, TRUE)
                if(enc %in% c("non-ASCII", "unknown")) enc <- def_enc
                cat("  ", sQuote(basename(file)),
                    if(nzchar(enc)) paste("using", sQuote(enc)),
                    "...")
                Rcmd <- paste0("options(warn=1)\ntools:::.run_one_vignette('",
                               basename(file), "', '", vigns$dir, "'",
                               if (nzchar(enc))
                                   paste0(", encoding = '", enc, "'"),
                               ", pkgdir='", vigns$pkgdir, "')")
                outfile <- paste0(basename(file), ".log")
                t1b <- proc.time()
                status <- R_runR(Rcmd,
                                 if (use_valgrind) paste(R_opts2, "-d valgrind") else R_opts2,
                                 ## add timing as footer, as BATCH does
                                 env = c(jitstr, "R_BATCH=1234", elibs,
                                 "_R_CHECK_INTERNALS2_=1"),
                                 stdout = outfile, stderr = outfile)
                t2b <- proc.time()
                out <- readLines(outfile, warn = FALSE)
                savefile <- file.path(dirname(file), paste0(name, ".Rout.save"))
                if(length(grep("^  When (running|tangling|sourcing)", out,
                               useBytes = TRUE))) {
                    cat(" failed\n")
                    res <- c(res,
                             paste("when running code in", sQuote(basename(file))),
                             "  ...",
                             utils::tail(out, as.numeric(Sys.getenv("_R_CHECK_VIGNETTES_NLINES_", 10))))
                } else if(status || ! " *** Run successfully completed ***" %in% out) {
                    ## (Need not be the final line if running under valgrind)
                    cat(" failed to complete the test\n")
                    out <- c(out, "", "... incomplete output.  Crash?")
                    res <- c(res,
                             paste("when running code in", sQuote(basename(file))),
                             "  ...",
                             utils::tail(out, as.numeric(Sys.getenv("_R_CHECK_VIGNETTES_NLINES_", 10))))
                } else if (file.exists(savefile)) {
                    cmd <- paste0("invisible(tools::Rdiff('",
                                 outfile, "', '", savefile, "',TRUE,TRUE))")
                    out2 <- R_runR(cmd, R_opts2)
                    if(length(out2)) {
                        print_time(t1b, t2b, NULL)
                        cat("\ndifferences from ", sQuote(basename(savefile)),
                            "\n", sep = "")
                        writeLines(c(out2, ""))
                    } else {
                        print_time(t1b, t2b, NULL)
                        cat(" OK\n")
                        if (!config_val_to_logical(Sys.getenv("_R_CHECK_ALWAYS_LOG_VIGNETTE_OUTPUT_", use_valgrind)))
                            unlink(outfile)
                    }
                } else {
                    print_time(t1b, t2b, NULL)
                    cat(" OK\n")
                    if (!config_val_to_logical(Sys.getenv("_R_CHECK_ALWAYS_LOG_VIGNETTE_OUTPUT_", use_valgrind)))
                        unlink(outfile)
                }
            }
            t2 <- proc.time()
            print_time(t1, t2, Log)
            if (R_check_suppress_RandR_message)
                res <- grep('^Xlib: *extension "RANDR" missing on display', res,
                            invert = TRUE, value = TRUE, useBytes = TRUE)
            if(length(res)) {
                if(length(grep("there is no package called", res,
                               useBytes = TRUE))) {
                    warningLog(Log, "Errors in running code in vignettes:")
                    printLog0(Log, paste(c(res, "", ""), collapse = "\n"))
                } else {
                    errorLog(Log, "Errors in running code in vignettes:")
                    printLog0(Log, paste(c(res, "", ""), collapse = "\n"))
                    do_exit(1L)
                }
            } else resultLog(Log, "OK")

            build_vignettes <-
                parse_description_field(desc, "BuildVignettes", TRUE)
            if (!build_vignettes && as_cran) {
                ## FOSS packages must be able to rebuild their vignettes
                info <- analyze_license(desc["License"])
                build_vignettes <- info$is_verified
            }
            if (do_build_vignettes && build_vignettes) {
                checkingLog(Log, "re-building of vignette outputs")
                ## copy the whole pkg directory to check directory
                ## so we can work in place, and allow ../../foo references.
                dir.create(vd2 <- "vign_test")
                if (!dir.exists(vd2)) {
                    errorLog(Log, "unable to create 'vign_test'")
                    do_exit(1L)
                }
                file.copy(pkgdir, vd2, recursive = TRUE)

                ## since so many people use 'R CMD' in Makefiles,
                oPATH <- Sys.getenv("PATH")
                Sys.setenv(PATH = paste(R.home("bin"), oPATH,
                           sep = .Platform$path.sep))
                on.exit(Sys.setenv(PATH = oPATH))
                ## And too many inst/doc/Makefile are not safe for
                ## parallel makes
                Sys.setenv(MAKEFLAGS="")
                ## we could use clean = FALSE, but that would not be
                ## testing what R CMD build uses.
                Rcmd <- "options(warn=1)\nlibrary(tools)\n"
                Rcmd <- paste0(Rcmd, "buildVignettes(dir = '",
                               file.path(pkgoutdir, "vign_test", pkgname0),
                               "')")
                t1 <- proc.time()
                outfile <- tempfile()
                status <- R_runR(Rcmd, R_opts2, jitstr,
                                 stdout = outfile, stderr = outfile)
                t2 <- proc.time()
                if (status) {
                    noteLog(Log)
                    out <- readLines(outfile, warn = FALSE)
                    if (R_check_suppress_RandR_message)
                        out <- grep('^Xlib: *extension "RANDR" missing on display', out,
                                    invert = TRUE, value = TRUE, useBytes = TRUE)
                    out <- utils::tail(out, 25)
                    printLog0(Log,
                              paste(c("Error in re-building vignettes:",
                                      "  ...", out, "", ""), collapse = "\n"))
                } else {
                    ## clean up
                    if (config_val_to_logical(Sys.getenv("_R_CHECK_CLEAN_VIGN_TEST_", "true")))
                        unlink(vd2, recursive = TRUE)
                    print_time(t1, t2, Log)
                    resultLog(Log, "OK")
                }
            } else {
                checkingLog(Log, "re-building of vignette outputs")
                resultLog(Log, "SKIPPED")
            }
        } else {
            checkingLog(Log, "running R code from vignettes")
            resultLog(Log, "SKIPPED")
            checkingLog(Log, "re-building of vignette outputs")
            resultLog(Log, "SKIPPED")
        }
    }

    check_pkg_manual <- function(pkgdir, pkgname)
    {
        ## Run Rd2pdf on the manual, if there are man pages
        ## If it is installed there is a 'help' dir
        ## and for a source package, there is a 'man' dir
        if (dir.exists(file.path(pkgdir, "help")) ||
            dir.exists(file.path(pkgdir, "man"))) {
            topdir <- pkgdir
            Rd2pdf_opts <- "--batch --no-preview"
            checkingLog(Log, "PDF version of manual")
            build_dir <- gsub("\\", "/", tempfile("Rd2pdf"), fixed = TRUE)
            man_file <- paste0(pkgname, "-manual.pdf ")
            ## precautionary remove in case some other attempt left it behind
            if(file.exists(man_file)) unlink(man_file)
            args <- c( "Rd2pdf ", Rd2pdf_opts,
                      paste0("--build-dir=", shQuote(build_dir)),
                      "--no-clean", "-o ", man_file , shQuote(topdir))
            res <- run_Rcmd(args,  "Rdlatex.log")
            latex_log <- file.path(build_dir, "Rd2.log")
            if (file.exists(latex_log))
                file.copy(latex_log, paste0(pkgname, "-manual.log"))
            if (res == 11) { ## return code from Rd2pdf
                errorLog(Log, "Rd conversion errors:")
                lines <- readLines("Rdlatex.log", warn = FALSE)
                lines <- grep("^(Hmm|Execution)", lines,
                              invert = TRUE, value = TRUE)
                printLog0(Log, paste(c(lines, ""), collapse = "\n"))
                unlink(build_dir, recursive = TRUE)
                do_exit(1L)
            } else if (res > 0) {
                latex_file <- file.path(build_dir, "Rd2.tex")
                if (file.exists(latex_file))
                    file.copy(latex_file, paste0(pkgname, "-manual.tex"))
                warningLog(Log)
                printLog0(Log,
                          paste0("LaTeX errors when creating PDF version.\n",
                                 "This typically indicates Rd problems.\n"))
                ## If possible, indicate the problems found.
                if (file.exists(latex_log)) {
                    lines <- .get_LaTeX_errors_from_log_file(latex_log)
                    printLog(Log, "LaTeX errors found:\n")
                    printLog0(Log, paste(c(lines, ""), collapse = "\n"))
                }
                unlink(build_dir, recursive = TRUE)
                ## for Windows' sake: errors can make it unwritable
                build_dir <- gsub("\\", "/", tempfile("Rd2pdf"), fixed = TRUE)
                checkingLog(Log, "PDF version of manual without hyperrefs or index")
                ## Also turn off hyperrefs.
                Sys.setenv(R_RD4PDF = "times")
                args <- c( "Rd2pdf ", Rd2pdf_opts,
                          paste0("--build-dir=", shQuote(build_dir)),
                          "--no-clean", "--no-index",
                          "-o ", man_file, topdir)
                if (run_Rcmd(args, "Rdlatex.log")) {
                    ## FIXME: the info is almost certainly in Rdlatex.log
                    errorLog(Log)
                    latex_log <- file.path(build_dir, "Rd2.log")
                    if (file.exists(latex_log))
                        file.copy(latex_log, paste0(pkgname, "-manual.log"))
                    else {
                        ## No log file and thus no chance to find out
                        ## what went wrong.  Hence, re-run without
                        ## redirecting stdout/stderr and hope that this
                        ## gives the same problem ...
                        # printLog(Log, "Error when running command:\n")
                        # cmd <- paste(c("R CMD", args), collapse = " ")
                        # printLog(Log, strwrap(cmd, indent = 2, exdent = 4), "\n")
                        printLog(Log, "Re-running with no redirection of stdout/stderr.\n")
                        unlink(build_dir, recursive = TRUE)
                        build_dir <- gsub("\\", "/", tempfile("Rd2pdf"), fixed = TRUE)
                        args <- c( "Rd2pdf ", Rd2pdf_opts,
                                  paste0("--build-dir=", shQuote(build_dir)),
                                  "--no-clean", "--no-index",
                                  "-o ", paste0(pkgname, "-manual.pdf "),
                                  topdir)
                        run_Rcmd(args)
                    }
                    unlink(build_dir, recursive = TRUE)
                    do_exit(1L)
                } else {
                    unlink(build_dir, recursive = TRUE)
                    resultLog(Log, "OK")
                }
            } else {
                unlink(build_dir, recursive = TRUE)
                resultLog(Log, "OK")
            }
        }
    }

    check_executables <- function()
    {
        owd <- setwd(pkgdir)
        allfiles <- dir(".", all.files = TRUE, full.names = TRUE,
                        recursive = TRUE)
        allfiles <- sub("^./","", allfiles)
        ## this is tailored to the FreeBSD/Linux 'file',
        ## see http://www.darwinsys.com/file/
        ## (Solaris has a different 'file' without --version)
        ## Most systems are now on >= 5.03, but Mac OS 10.5 was 4.17
        ## version 4.21 writes to stdout,
        ## 4.23 to stderr and sets an error status code
        FILE <- "file"
        lines <- suppressWarnings(tryCatch(system2(FILE, "--version", TRUE, TRUE), error = function(e) "error"))
        ## a reasonable check -- it does not identify itself well
        have_free_file <- any(grepl("^(file-[45]|magic file from)", lines))
        if (!have_free_file) {
            ## OpenCSW calls this 'gfile'
            FILE <- "gfile"
            lines <- suppressWarnings(tryCatch(system2(FILE, "--version", TRUE, TRUE), error = function(e) "error"))
            have_free_file <- any(grepl("magic file from", lines))
        }
        if (have_free_file) {
            checkingLog(Log, "for executable files")
            ## Watch out for spaces in file names here
            ## Do in parallel for speed on Windows, but in batches
            ## since there may be a line-length limit.
            execs <- character()
            files <- allfiles
            while(ll <- length(files)) {
                chunk <- seq_len(min(100, ll))
                these <- files[chunk]
                files <- files[-chunk]
                lines <- suppressWarnings(system2(FILE, shQuote(these), TRUE, TRUE))
                ## avoid match to is_executable.Rd
                ex <- grepl(" executable", lines, useBytes=TRUE)
		ex2 <- grepl("script", lines, useBytes=TRUE) &
		       grepl("text", lines, useBytes=TRUE)
                execs <- c(execs, lines[ex & !ex2])
            }
            if(length(execs)) {
                execs <- sub(":[[:space:]].*$", "", execs, useBytes = TRUE)
                known <- rep(FALSE, length(execs))
                pexecs <- file.path(pkgname, execs)
                ## known false positives
                for(fp in  c("foreign/tests/datefactor.dta",
                             "msProcess/inst/data[12]/.*.txt",
                             "WMBrukerParser/inst/Examples/C3ValidationExtractSmall/RobotRun1/2-100kDa/0_B1/1/1SLin/fid",
                             "bayesLife/inst/ex-data/bayesLife.output/predictions/traj_country104.rda" # file 5.16
                             ) )
                    known <- known | grepl(fp, pexecs)
                execs <- execs[!known]
            }
        } else {
            ## no 'file', so just check extensions
            checkingLog(Log, "for .dll and .exe files")
            execs <- grep("\\.(exe|dll)$", allfiles, value = TRUE)
        }
        if (R_check_executables_exclusions && file.exists("BinaryFiles")) {
            excludes <- readLines("BinaryFiles")
            execs <- execs[!execs %in% excludes]
        }
        if (nb <- length(execs)) {
            msg <- ngettext(nb,
                            "Found the following executable file:",
                            "Found the following executable files:",
                            domain = NA)
            warningLog(Log, msg)
            printLog0(Log, .format_lines_with_indent(execs), "\n")
            wrapLog("Source packages should not contain undeclared executable files.\n",
                    "See section 'Package structure'",
                    "in the 'Writing R Extensions' manual.\n")
        } else resultLog(Log, "OK")
        setwd(owd)
    }

    ## CRAN-pack knows about
    .hidden_file_exclusions <-
        c(".Renviron", ".Rprofile", ".Rproj.user",
          ".Rhistory", ".Rapp.history",
          ".tex", ".log", ".aux", ".pdf", ".png",
          ".backups", ".cvsignore", ".cproject", ".directory",
          ".dropbox", ".exrc", ".gdb.history",
          ".gitattributes", ".gitignore", ".gitmodules",
          ".hgignore", ".hgtags",
          ".project", ".seed", ".settings", ".tm_properties")

    check_dot_files <- function(cran = FALSE)
    {
        checkingLog(Log, "for hidden files and directories")
        owd <- setwd(pkgdir)
        dots <- dir(".", all.files = TRUE, full.names = TRUE,
                        recursive = TRUE, pattern = "^[.]")
        dots <- sub("^./","", dots)
        allowed <-
            c(".Rbuildignore", ".Rinstignore", "vignettes/.install_extras")
        dots <- dots[!dots %in% allowed]
        alldirs <- list.dirs(".", full.names = TRUE, recursive = TRUE)
        alldirs <- sub("^./","", alldirs)
        alldirs <- alldirs[alldirs != "."]
        bases <- basename(alldirs)
        dots <- c(dots, alldirs[grepl("^[.]", bases)])
        if (length(dots)) {
            noteLog(Log, "Found the following hidden files and directories:")
            printLog0(Log, .format_lines_with_indent(dots), "\n")
            wrapLog("These were most likely included in error.",
                    "See section 'Package structure'",
                    "in the 'Writing R Extensions' manual.\n")
            if(cran) {
                known <- basename(dots) %in% .hidden_file_exclusions
                known <- known | grepl("^.Rbuildindex[.]", dots) |
                  grepl("inst/doc/[.](Rinstignore|build[.]timestamp)$", dots) |
                  grepl("vignettes/[.]Rinstignore$", dots) |
                  grepl("^src.*/[.]deps$", dots)
               if (all(known))
                    printLog(Log, "\nCRAN-pack knows about all of these\n")
                else if (any(!known)) {
                    printLog(Log, "\nCRAN-pack does not know about\n")
                    printLog0(Log, .format_lines_with_indent(dots[!known]), "\n")
                }
            }
        } else resultLog(Log, "OK")
        setwd(owd)
    }

    check_install <- function()
    {
        ## Option '--no-install' turns off installation and the tests
        ## which require the package to be installed.  When testing
        ## recommended packages bundled with R we can skip
        ## installation, and do so if '--install=skip' was given.  If
        ## command line option '--install' is of the form
        ## 'check:FILE', it is assumed that installation was already
        ## performed with stdout/stderr redirected to FILE, the
        ## contents of which need to be checked (without repeating the
        ## installation).  In this case, one also needs to specify
        ## *where* the package was installed to using command line
        ## option '--library'.

        if (install == "skip")
            messageLog(Log, "skipping installation test")
        else {
            use_install_log <-
                (grepl("^check", install) || R_check_use_install_log
                 || !isatty(stdout()))
            INSTALL_opts <- install_args
            ## don't use HTML, checkRd goes over the same ground.
            INSTALL_opts <- c(INSTALL_opts,  "--no-html")
            if (install == "fake")
                INSTALL_opts <- c(INSTALL_opts,  "--fake")
            else if (!multiarch)
                INSTALL_opts <- c(INSTALL_opts,  "--no-multiarch")
            INSTALL_opts <- paste(INSTALL_opts, collapse = " ")
            args <- c("INSTALL", "-l", shQuote(libdir), INSTALL_opts,
                      shQuote(if (WINDOWS) shortPathName(pkgdir) else pkgdir))
            if (!use_install_log) {
                ## Case A: No redirection of stdout/stderr from installation.
                ## This is very rare: needs _R_CHECK_USE_INSTALL_LOG_ set
                ## to false.
                message("")
                ## Rare use of R CMD INSTALL
                if (run_Rcmd(args)) {
                    errorLog(Log, "Installation failed.")
                    do_exit(1L)
                }
                message("")
            } else {
                ## Case B. All output from installation redirected,
                ## or already available in the log file.
                checkingLog(Log,
                            "whether package ",
                            sQuote(desc["Package"]),
                            " can be installed")
                outfile <- file.path(pkgoutdir, "00install.out")
                if (grepl("^check", install)) {
                    if (!nzchar(arg_libdir))
                        printLog(Log, "\nWarning: --install=check... specified without --library\n")
                    thislog <- substr(install, 7L, 1000L)
                                        #owd <- setwd(startdir)
                    if (!file.exists(thislog)) {
                        errorLog(Log,
                                 sprintf("install log %s does not exist", sQuote(thislog)))
                        do_exit(2L)
                    }
                    file.copy(thislog, outfile)
                                        #setwd(owd)
                    install <- "check"
                    lines <- readLines(outfile, warn = FALSE)
                    ## <NOTE>
                    ## We used to have
                    ## $install_error = ($lines[$#lines] !~ /^\* DONE/);
                    ## but what if there is output from do_cleanup
                    ## in (Unix) R CMD INSTALL?
                    ## </NOTE>
                    install_error <- !any(grepl("^\\* DONE", lines))
                } else {
                    ## record in the log what options were used
                    cat("* install options ", sQuote(INSTALL_opts),
                        "\n\n", sep = "", file = outfile)
                    env <- ""
                    ## Normal use of R CMD INSTALL
                    t1 <- proc.time()
                    install_error <- run_Rcmd(args, outfile)
                    t2 <- proc.time()
                    print_time(t1, t2, Log)
                    lines <- readLines(outfile, warn = FALSE)
                }
                if (install_error) {
                    errorLog(Log, "Installation failed.")
                    printLog0(Log, "See ", sQuote(outfile),
                             " for details.\n")
                    do_exit(1L)
                }

                ## There could still be some important warnings that
                ## we'd like to report.  For the time being, start
                ## with compiler warnings about non ISO C code (or
                ## at least, what looks like it), and also include
                ## warnings resulting from the const char * CHAR()
                ## change in R 2.6.0.  (In theory, we should only do
                ## this when using GCC ...)

                if (install != "check")
                    lines <- readLines(outfile, warn = FALSE)

                lines0 <- lines
                warn_re <- c("^WARNING:",
                             "^Warning:",
                             ## <FIXME>
                             ## New style Rd conversion
                             ## which may even show errors:
                             "^Rd (warning|error): ",
                             ## </FIXME>
                             ": warning: .*ISO C",
                             ": warning: .* discards qualifiers from pointer target type",
                             ": warning: .* is used uninitialized",
                             ": warning: .* set but not used",
                             ": warning: unused",
                             ## clang warning about invalid returns.
                             "warning: void function",
                             "warning: control reaches end of non-void function",
                             "warning: no return statement in function returning non-void",
                             ": #warning",
                             # these are from era of static HTML
                             "missing links?:")
                ## Warnings spotted by gcc with
                ##   '-Wimplicit-function-declaration'
                ## which is implied by '-Wall'.
                ## Currently only accessible via an internal environment
                ## variable.
                check_src_flag <-
                    Sys.getenv("_R_CHECK_SRC_MINUS_W_IMPLICIT_", "FALSE")
                ## (Not quite perfect, as the name should really
                ## include 'IMPLICIT_FUNCTION_DECLARATION'.)
                if (config_val_to_logical(check_src_flag)) {
                    warn_re <- c(warn_re,
                                 ": warning: implicit declaration of function",
                                 ": warning: incompatible implicit declaration of built-in function")
                }

                ## Warnings spotted by clang with
                ## '-Wreturn-type-c-linkage':
                warn_re <- c(warn_re,
                             ": warning: .* \\[-Wreturn-type-c-linkage\\]")

                warn_re <- paste0("(", paste(warn_re, collapse = "|"), ")")

                lines <- grep(warn_re, lines, value = TRUE, useBytes = TRUE)

                ## Ignore install-time readLines() warnings about
                ## files with incomplete final lines.  Most of these
                ## come from .install_package_indices(), and should be
                ## safe to ignore ...
                lines <- grep("Warning: incomplete final line found by readLines",
                              lines, invert = TRUE, value = TRUE, useBytes = TRUE)

                check_Stangle <- Sys.getenv("_R_CHECK_STANGLE_WARNINGS_", "TRUE")
                if (!config_val_to_logical(check_Stangle))
                lines <- grep("Warning: value of .* option should be lowercase",
                              lines, invert = TRUE, value = TRUE, useBytes = TRUE)

                ## Package writers cannot really do anything about
                ## non ISO C code in *system* headers.  Also,
                ## GCC >= 3.4 warns about function pointers
                ## casts which are "needed" for dlsym(), but it
                ## seems that all systems which have dlsym() also
                ## support the cast.  Hence, try to ignore these by
                ## default, but make it possible to get all ISO C
                ## warnings via an environment variable.
                if (!R_check_all_non_ISO_C) {
                    lines <- grep("^ */.*: warning: .*ISO C",
                                  lines, invert = TRUE, value = TRUE, useBytes = TRUE)
                    lines <- grep("warning: *ISO C forbids.*function pointer",
                                  lines, invert = TRUE, value = TRUE, useBytes = TRUE)
                }

                ## Warnings spotted by gcc with
                ##   '-Wunused'
                ## which is implied by '-Wall'.
                ## Currently only accessible via an internal environment
                ## variable.
                check_src_flag <-
                    Sys.getenv("_R_CHECK_SRC_MINUS_W_UNUSED_", "FALSE")
                if (!config_val_to_logical(check_src_flag)) {
                    lines <- grep("warning: unused", lines, ignore.case = TRUE,
                                  invert = TRUE, value = TRUE, useBytes = TRUE)
                    lines <- grep("warning: .* set but not used", lines,
                                  ignore.case = TRUE,
                                  invert = TRUE, value = TRUE, useBytes = TRUE)
                }
                ## (gfortran seems to use upper case.)

                ## Warnings spotted by clang with
                ##   '-Wsometimes-uninitialized'
                ## which is implied by '-Wall'.
                ## Currently only accessible via an internal environment
                ## variable.
                check_src_flag <-
                    Sys.getenv("_R_CHECK_SRC_MINUS_W_SOMETIMES_UNINITIALIZED_",
                               "FALSE")
                if (!config_val_to_logical(check_src_flag)) {
                    lines <- grep("warning: .* is used uninitialized whenever",
                                  lines,
                                  invert = TRUE, value = TRUE, useBytes
                                  = TRUE)
                }

                ## Warnings spotted by gfortran >= 4.0 with '-Wall'.
                ## Justified in principle, it seems.
                ## Let's filter them for the time being, and maybe
                ## revert this later on ... but make it possible to
                ## suppress filtering out by setting the internal
                ## environment variable _R_CHECK_WALL_FORTRAN_ to
                ## something "true".
                check_src_flag <- Sys.getenv("_R_CHECK_WALL_FORTRAN_", "FALSE")
                if (!config_val_to_logical(check_src_flag)) {
                    warn_re <-
                        c("Label .* at \\(1\\) defined but not used",
                          "Line truncated at \\(1\\)",
                          "ASSIGN statement at \\(1\\)",
                          "Assigned GOTO statement at \\(1\\)",
                          "arithmetic IF statement at \\(1\\)",
                          "Nonconforming tab character (in|at)")
                    warn_re <- paste0("(", paste(warn_re, collapse = "|"), ")")
                    lines <- grep(warn_re, lines, invert = TRUE, value = TRUE)
                }

                if (WINDOWS) {
                    ## Warning on Windows with some packages that
                    ## cannot transparently be installed bi-arch.
                    lines <- grep("Warning: this package has a non-empty 'configure.win' file",
                                  lines, invert = TRUE, value = TRUE)
                    ## Warning on x64 Windows gcc 4.5.1 that
                    ## seems to be spurious
                    lines <- grep("Warning: .drectve .* unrecognized",
                                  lines, invert = TRUE, value = TRUE)
                }

                check_imports_flag <-
                    Sys.getenv("_R_CHECK_REPLACING_IMPORTS_", "TRUE")
                if (!config_val_to_logical(check_imports_flag))
                    lines <- grep("Warning: replacing previous import", lines,
                                  fixed = TRUE, invert = TRUE, value = TRUE)
                else {
                    this <- unique(grep("Warning: replacing previous import",
                                        lines, fixed = TRUE, value = TRUE))
                    this <- grep(paste0(sQuote(pkgname), "$"), this,
                                 value = TRUE)
                    lines <- grep("Warning: replacing previous import", lines,
                                  fixed = TRUE, invert = TRUE, value = TRUE)
                    lines <- c(lines, this)
                }
                check_FirstLib_flag <-
                    Sys.getenv("_R_CHECK_DOT_FIRSTLIB_", "FALSE")
                if (!config_val_to_logical(check_FirstLib_flag))
                    lines <- grep("Warning: ignoring .First.lib()", lines,
                                  fixed = TRUE, invert = TRUE, value = TRUE)

                if (length(lines)) {
                    warningLog(Log, "Found the following significant warnings:")
                    printLog0(Log, .format_lines_with_indent(lines), "\n")
                    printLog0(Log, sprintf("See %s for details.\n",
                                           sQuote(outfile)))
                } else resultLog(Log, "OK")
            }   ## end of case B
        }

    }

    ## This requires a GNU-like 'du' with 1k block sizes,
    ## so use -k (which POSIX requires).
    ## It also depends on the total being last.
    check_install_sizes <- function()
    {
        ## if we used a log, the installation need not still exist.
        pd <- file.path(libdir, pkgname)
        if (!dir.exists(pd)) return()
        checkingLog(Log, "installed package size")
        owd <- setwd(pd)
        res <- system2("du", "-k", TRUE, TRUE)
        sizes <- as.integer(sub("\\D.*", "", res))
        dirs <- sub("^\\d*\\s*", "", res)
        res2 <- data.frame(size = sizes, dir = I(dirs))
        total <- res2[nrow(res2), 1L]
        if(!is.na(total) && total > 1024*5) { # report at 5Mb
            noteLog(Log)
            printLog(Log, sprintf("  installed size is %4.1fMb\n", total/1024))
            rest <- res2[-nrow(res2), ]
            rest[, 2L] <- sub("./", "", rest[, 2L])
            # keep only top-level directories
            rest <- rest[!grepl("/", rest[, 2L]), ]
            rest <- rest[rest[, 1L] > 1024, ] # > 1Mb
            if(nrow(rest)) {
                o <- sort.list(rest[, 2L])
                printLog(Log, "  sub-directories of 1Mb or more:\n")
                size <- sprintf('%4.1fMb', rest[, 1L]/1024)
                printLog0(Log,
                          paste("    ",
                                format(rest[o, 2L], justify = "left"),
                                "  ",
                                format(size[o], justify = "right"),
                                "\n",
                                sep=""))
            }
        } else resultLog(Log, "OK")
        setwd(owd)
    }

    check_description <- function()
    {
        checkingLog(Log, "for file ",
                    sQuote(file.path(pkgname0, "DESCRIPTION")))
        if ("DESCRIPTION" %in% dir(pkgdir)) {
            f <- file.path(pkgdir, "DESCRIPTION")
            desc <- try(.read_description(f))
            if (inherits(desc, "try-error") || !length(desc)) {
                resultLog(Log, "EXISTS but not correct format")
                do_exit(1L)
            }
            mandatory <- c("Package", "Version", "License", "Description",
                           "Title", "Author", "Maintainer")
            OK <- sapply(desc[mandatory], function(x) !is.na(x) && nzchar(x))
            if(!all(OK)) {
                fail <- mandatory[!OK]
                msg <- ngettext(length(fail),
                                "Required field missing or empty:",
                                "Required fields missing or empty:")
                msg <- paste0(msg, "\n", .pretty_format(fail))
                errorLog(Log, msg)
                do_exit(1L)
            }
            if(!grepl("^[[:alpha:]][[:alnum:].]*[[:alnum:]]$", desc["Package"])
               || grepl("[.]$", desc["Package"])) {
                warningLog(Log)
                printLog(Log,"  Package name is not portable:\n",
                         "  It must start with a letter, contain letters, digits or dot\n",
                         "  have at least 2 characters and not end with a dot.\n")
            } else resultLog(Log, "OK")
            encoding <- desc["Encoding"]
        } else if (file.exists(f <- file.path(pkgdir, "DESCRIPTION"))) {
            errorLog(Log,
                     "File DESCRIPTION does not exist but there is a case-insenstiive match.")
            do_exit(1L)
        } else {
            resultLog(Log, "NO")
            do_exit(1L)
        }
        if (!is.na(desc["Type"])) { # standard packages do not have this
            checkingLog(Log, "extension type")
            resultLog(Log, desc["Type"])
            if (desc["Type"] != "Package") {
                printLog(Log,
                         "Only 'Type = Package' extensions can be checked.\n")
                do_exit(0L)
            }
        }
        if (!is.na(desc["Bundle"])) {
            messageLog(Log, "looks like ", sQuote(pkgname0),
                       " is a package bundle -- they are defunct")
            errorLog(Log, "")
            do_exit(1L)
        }

        messageLog(Log,
                   sprintf("this is package %s version %s",
                           sQuote(desc["Package"]),
                           sQuote(desc["Version"])))

        if (!is.na(encoding))
            messageLog(Log, "package encoding: ", encoding)

        desc
    }

    check_CRAN_incoming <- function()
    {
        checkingLog(Log, "CRAN incoming feasibility")
        res <- .check_package_CRAN_incoming(pkgdir)
        if(length(res)) {
            out <- format(res)
            if(length(res$bad_package)) {
                errorLog(Log)
                printLog0(Log, paste(c(out, ""), collapse = "\n"))
                do_exit(1L)
            } else if(length(res$bad_version) ||
                      identical(res$foss_with_BuildVigettes, TRUE) ||
                      res$empty_Maintainer_name ||
                      res$Maintainer_needs_quotes)
                warningLog(Log)
            else if(length(res) > 1L) noteLog(Log)
            else resultLog(Log, "OK")
            printLog0(Log, paste(out, "\n", sep = ""))
        } else resultLog(Log, "OK")
    }

    check_dependencies <- function()
    {
        ## Try figuring out whether the package dependencies can be
        ## resolved at run time.  Ideally, the installation
        ## mechanism would do this, and we also do not check
        ## versions ... also see whether vignette and namespace
        ## package dependencies are recorded in DESCRIPTION.

        ## <NOTE>
        ## We are not checking base packages here, so all packages do
        ## have a description file.
        ## </NOTE>

        ## <NOTE>
        ## If a package has a namespace, checking dependencies will
        ## try making use of it without the NAMESPACE file ever
        ## being validated.
        ## Uncaught errors can lead to messages like
        ##   * checking package dependencies ... ERROR
        ##   Error in e[[1]] : object is not subsettable
        ##   Execution halted
        ## which are not too helpful :-(
        ## Hence, we try to intercept this here.

        if (!extra_arch &&
            file.exists(file.path(pkgdir, "NAMESPACE"))) {
            checkingLog(Log, "package namespace information")
            ns <- tryCatch(parseNamespaceFile(basename(pkgdir),
                                              dirname(pkgdir)),
                     error = function(e) {
                         errorLog(Log)
                         printLog0(Log,
                                   "Invalid NAMESPACE file, parsing gives:",
                                   "\n", as.character(e), "\n")
                         msg_NAMESPACE <-
                             c("See section 'Package namespaces'",
                               " of the 'Writing R Extensions' manual.\n")
                         wrapLog(msg_NAMESPACE)
                         do_exit(1L)
                     })
            nS3methods <- nrow(ns$S3methods)
            if (nS3methods > 500L) {
                ## check that this is installable in R 3.0.1
                meta <- .read_description(file.path(pkgdir, "DESCRIPTION"))
                deps <- .split_description(meta, verbose = TRUE)$Rdepends2
                status <- 0L
                current <- as.numeric_version("3.0.1")
                for(depends in deps) {
                    ## .check_package_description will insist on these operators
                    if(!depends$op %in% c("<=", ">=", "<", ">", "==", "!="))
                        next
                    status <- if(inherits(depends$version, "numeric_version"))
                        !do.call(depends$op, list(current, depends$version))
                    else {
                        ver <- R.version
                        if (ver$status %in% c("", "Patched")) FALSE
                        else !do.call(depends$op,
                                      list(ver[["svn rev"]],
                                           as.numeric(sub("^r", "", depends$version))))
                    }
                    if(status != 0L)  break
                }
                if (status == 0L) {
                    msg <- sprintf("R < 3.0.2 had a limit of 500 registered S3 methods: found %d",
                                   nS3methods)
                    noteLog(Log, msg)
                } else
                    resultLog(Log, "OK")
            } else
                resultLog(Log, "OK")
        }

        checkingLog(Log, "package dependencies")
        ## Everything listed in Depends or Suggests or Imports
        ## should be available for successfully running R CMD check.
        ## \VignetteDepends{} entries not "required" by the package code
        ## must be in Suggests.  Note also that some of us think that a
        ## package vignette must require its own package, which OTOH is
        ## not required in the package DESCRIPTION file.
        ## Namespace imports must really be in Depends.
        res <- .check_package_depends(pkgdir, R_check_force_suggests,
                                      check_incoming)
        if(any(sapply(res, length) > 0L)) {
            out <- format(res)
            allowed <- c("suggests_but_not_installed",
                         "enhances_but_not_installed",
                         "many_depends",
                         "skipped",
                         "hdOnly",
                         if(!check_incoming) "bad_engine")
            if(!all(names(res) %in% allowed)) {
                errorLog(Log)
                printLog0(Log, paste(out, collapse = "\n"), "\n")
                if(length(res$suggested_but_not_installed))
                   wrapLog("The suggested packages are required for",
                           "a complete check.\n",
                           "Checking can be attempted without them",
                           "by setting the environment variable",
                           "_R_CHECK_FORCE_SUGGESTS_",
                           "to a false value.\n\n")
                wrapLog(msg_DESCRIPTION)
                do_exit(1L)
            } else {
                noteLog(Log)
                printLog0(Log, paste(out, collapse = "\n"))
            }
        } else resultLog(Log, "OK")
    }

    check_sources <- function()
    {
        checkingLog(Log, "if this is a source package")
        ## <NOTE>
        ## This check should be adequate, but would not catch a manually
        ## installed package, nor one installed prior to 1.4.0.
        ## </NOTE>
        if (!is.na(desc["Built"])) {
            errorLog(Log)
            printLog(Log, "Only *source* packages can be checked.\n")
            do_exit(1L)
        } else if (!grepl("^check", install)) {
            ini <- character()
            ## Check for package 'src' subdirectories with object
            ## files (but not if installation was already performed).
            pat <- "(a|o|[ls][ao]|sl|obj|dll)" # Object file/library extensions.
            any <- FALSE
            srcd <- file.path(pkgdir, "src")
            if (dir.exists(srcd) &&
                length(of <- list_files_with_exts(srcd, pat))) {
                if (!any) warningLog(Log)
                any <- TRUE
                of <- sub(paste0(".*/", file.path(pkgname, "src"), "/"),
                          "", of)
                printLog0(Log,
                          sprintf("Subdirectory %s contains apparent object files/libraries\n",
                                  sQuote(file.path(pkgname, "src"))),
                          paste(strwrap(paste(of, collapse = " "),
                                        indent = 2L, exdent = 2L),
                                collapse = "\n"),
                          "\nObject files/libraries should not be included in a source package.\n")
                ini <- ""
            }
            ## A submission had src-i386 etc from multi-arch builds
            ad <- list.dirs(pkgdir, recursive = FALSE)
            if(thispkg_src_subdirs != "no" &&
               any(ind <- grepl("/src-(i386|x64|x86_64|ppc)$", ad))) {
                if(!any) warningLog(Log)
                any <- TRUE
                msg <- ngettext(sum(ind),
                                "Found the following directory with a name of a multi-arch build directory:\n",
                                "Found the following directories with names of multi-arch build directories:\n",
                                domain = NA)
                printLog0(Log,
                          ini,
                          msg,
                          .format_lines_with_indent(basename(ad[ind])),
                          "\n",
                          "Most likely, these were included erroneously.\n")
                ini <- ""
            }
            if (thispkg_src_subdirs != "no" && dir.exists(srcd)) {
                setwd(srcd)
                if (!file.exists("Makefile") &&
                    !file.exists("Makefile.win") &&
                    !(file.exists("Makefile.in") && spec_install)) {
                    ## Recognized extensions for sources or headers.
                    srcfiles <- dir(".", all.files = TRUE)
                    fi <- file.info(srcfiles)
                    srcfiles <- srcfiles[!fi$isdir]
                    srcfiles <- grep("(\\.([cfmCM]|cc|cpp|f90|f95|mm|h|o|so)$|^Makevars|-win\\.def$)",
                                     srcfiles,
                                     invert = TRUE, value = TRUE)
                    if (length(srcfiles)) {
                        if (!any) warningLog(Log)
                        any <- TRUE
                        msg <- c(ini,
                                 paste("Subdirectory",
                                       sQuote("src"),
                                       "contains:"),
                                 strwrap(paste(srcfiles, collapse = " "),
                                         indent = 2, exdent = 2),
                                 strwrap("These are unlikely file names for src files."),
                                 "")
                        printLog0(Log, paste(msg, collapse = "\n"))
                        ini <- ""
                    }
                }
                setwd(startdir)
            }
            ## All remaining checks give notes and not warnings.
            if(length(ini))
                ini <- c("",
                         "In addition to the above warning(s), found the following notes:",
                         "")
            files <- list.files(pkgdir, recursive = TRUE)
            ## Check for object files not directly in src.
            ## (Note that the above does not look for object files in
            ## subdirs of src.)
            bad <- files[grepl(sprintf("\\.%s$", pat), basename(files))]
            bad <- bad[dirname(bad) != "src" |
                       dirname(dirname(bad)) != "."]
            if(length(bad)) {
                if(!any) noteLog(Log)
                any <- TRUE
                msg <- c(ini,
                         "Found the following apparent object files/libraries:",
                         strwrap(paste(bad, collapse = " "),
                                 indent = 2L, exdent = 2L),
                         "Object files/libraries should not be included in a source package.\n")
                printLog0(Log, paste(msg, collapse = "\n"))
                ini <- ""
            }
            ## Check for installed copies of the package in some subdir.
            files <- files[basename(dirname(files)) == "Meta"]
            if(length(files) &&
               all(!is.na(match(c("package.rds", "hsearch.rds"),
                                basename(files))))) {
                if(!any) noteLog(Log)
                any <- TRUE
                msg <- c(ini,
                         sprintf("Subdirectory %s seems to contain an installed version of the package.\n",
                                 sQuote(dirname(dirname(files[1L])))))
                printLog0(Log, paste(msg, collapse = "\n"))
            }
            if (!any) resultLog(Log, "OK")
        } else resultLog(Log, "OK")
    }

    dir.exists <- function(x) !is.na(isdir <- file.info(x)$isdir) & isdir

    do_exit <- function(status = 1L) q("no", status = status, runLast = FALSE)

    env_path <- function(...) {
        paths <- c(...)
        paste(paths[nzchar(paths)], collapse = .Platform$path.sep)
    }

    Usage <- function() {
        cat("Usage: R CMD check [options] pkgs",
            "",
            "Check R packages from package sources, which can be directories or",
            "package 'tar' archives with extension '.tar.gz', '.tar.bz2',",
            "'.tar.xz' or '.tgz'.",
            "",
            "A variety of diagnostic checks on directory structure, index and",
            "control files are performed.  The package is installed into the log",
            "directory and production of the package PDF manual is tested.",
            "All examples and tests provided by the package are tested to see if",
            "they run successfully.  Code in the vignettes is tested,",
            "as is re-building the vignette PDFs.",
            "",
            "Options:",
            "  -h, --help		print short help message and exit",
            "  -v, --version		print version info and exit",
            "  -l, --library=LIB     library directory used for test installation",
            "			of packages (default is outdir)",
            "  -o, --output=DIR      directory for output, default is current directory.",
            "			Logfiles, R output, etc. will be placed in 'pkg.Rcheck'",
            "			in this directory, where 'pkg' is the name of the",
            "			checked package",
            "      --no-clean        do not clean 'outdir' before using it",
            "      --no-codoc        do not check for code/documentation mismatches",
            "      --no-examples     do not run the examples in the Rd files",
            "      --no-install      skip installation and associated tests",
            "      --no-tests        do not run code in 'tests' subdirectory",
            "      --no-manual       do not produce the PDF manual",
            "      --no-vignettes    do not run R code in vignettes",
            "      --no-build-vignettes    do not build vignette outputs",
            "      --use-gct         use 'gctorture(TRUE)' when running examples/tests",
            "      --use-valgrind    use 'valgrind' when running examples/tests/vignettes",
            "      --timings         record timings for examples",
            "      --install-args=	command-line args to be passed to INSTALL",
            "      --check-subdirs=default|yes|no",
            "			run checks on the package subdirectories",
            "			(default is yes for a tarball, no otherwise)",
            "      --as-cran         select customizations similar to those used",
            "                        for CRAN incoming checking",
            "",
            "The following options apply where sub-architectures are in use:",
            "      --extra-arch      do only runtime tests needed for an additional",
            "                        sub-architecture.",
            "      --multiarch       do runtime tests on all installed sub-archs",
            "      --no-multiarch    do runtime tests only on the main sub-architecture",
            "      --force-multiarch run tests on all sub-archs even for packages",
            "                        with no compiled code",
            "",
            "By default, all test sections are turned on.",
            "",
            "Report bugs at bugs.r-project.org .", sep="\n")
    }

###--- begin{.check_packages()} "main" ---

    options(showErrorCalls=FALSE, warn = 1)

    ## Read in check environment file.
    Renv <- Sys.getenv("R_CHECK_ENVIRON", unset = NA)
    if(!is.na(Renv)) {
        ## Do not read any check environment file if R_CHECK_ENVIRON is
        ## set to empty of something non-existent.
        if(nzchar(Renv) && file.exists(Renv)) readRenviron(Renv)
    } else {
        ## Read in ~/.R/check.Renviron[.rarch] (if it exists).
        rarch <- .Platform$r_arch
        if (nzchar(rarch) &&
            file.exists(Renv <- paste("~/.R/check.Renviron", rarch, sep = ".")))
            readRenviron(Renv)
        else if (file.exists(Renv <- "~/.R/check.Renviron"))
            readRenviron(Renv)
    }

    td0 <- as.numeric(Sys.getenv("_R_CHECK_TIMINGS_"))
    if (is.na(td0)) td0 <- Inf

    ## A user might have turned on JIT compilation.  That does not
    ## work well, so mostly disable it
    jit <- Sys.getenv("R_ENABLE_JIT")
    jitstr <- if(nzchar(jit)) {
        Sys.setenv(R_ENABLE_JIT = "0")
        paste0("R_ENABLE_JIT=", jit)
    } else character()

    if (is.null(args)) {
        args <- commandArgs(TRUE)
        ## it seems that splits on spaces, so try harder.
        args <- paste(args, collapse=" ")
        args <- strsplit(args,'nextArg', fixed = TRUE)[[1L]][-1L]
    }

    clean <- TRUE
    do_codoc <- TRUE
    do_examples <- TRUE
    do_install_arg <- TRUE; install <- ""
    do_tests <- TRUE
    do_vignettes <- TRUE
    do_build_vignettes <- TRUE
    do_manual <- TRUE
    use_gct <- FALSE
    use_valgrind <- FALSE
    do_timings <- FALSE
    install_args <- NULL
    check_subdirs <- ""           # defaults to R_check_subdirs_strict
    extra_arch <- FALSE
    spec_install <- FALSE
    multiarch <- NA
    force_multiarch <- FALSE
    as_cran <- FALSE

    libdir <- ""
    outdir <- ""
    pkgs <- character()
    while(length(args)) {
        a <- args[1L]
        if (a %in% c("-h", "--help")) {
            Usage()
            do_exit(0L)
        }
        else if (a %in% c("-v", "--version")) {
            cat("R add-on package check: ",
                R.version[["major"]], ".",  R.version[["minor"]],
                " (r", R.version[["svn rev"]], ")\n", sep = "")
            cat("",
                "Copyright (C) 1997-2013 The R Core Team.",
                "This is free software; see the GNU General Public License version 2",
                "or later for copying conditions.  There is NO warranty.",
                sep="\n")
            do_exit(0L)
        } else if (a == "-o") {
            if (length(args) >= 2L) {outdir <- args[2L]; args <- args[-1L]}
            else stop("-o option without value", call. = FALSE)
        } else if (substr(a, 1, 9) == "--output=") {
            outdir <- substr(a, 10, 1000)
        } else if (a == "-l") {
            if (length(args) >= 2L) {libdir <- args[2L]; args <- args[-1L]}
            else stop("-l option without value", call. = FALSE)
        } else if (substr(a, 1, 10) == "--library=") {
            libdir <- substr(a, 11, 1000)
        } else if (a == "--no-clean") {
            clean  <- FALSE
        } else if (a == "--no-codoc") {
            do_codoc  <- FALSE
        } else if (a == "--no-examples") {
            do_examples  <- FALSE
        } else if (a == "--no-install") {
            do_install_arg  <- FALSE
        } else if (substr(a, 1, 10) == "--install=") {
            install <- substr(a, 11, 1000)
        } else if (a == "--no-tests") {
            do_tests  <- FALSE
        } else if (a == "--no-build-vignettes") {
            do_build_vignettes  <- FALSE
        } else if (a == "--no-rebuild-vignettes") { # pre-3.0.0 version
            stop("'--no-rebuild-vignettes' is defunct: use '--no-build-vignettes' instead",
                 call. = FALSE, domain = NA)
      } else if (a == "--no-vignettes") {
            do_vignettes  <- FALSE
        } else if (a == "--no-manual") {
            do_manual  <- FALSE
        } else if (a == "--no-latex") {
            stop("'--no-latex' is defunct: use '--no-manual' instead",
                 call. = FALSE, domain = NA)
        } else if (a == "--use-gct") {
            use_gct  <- TRUE
        } else if (a == "--use-valgrind") {
            use_valgrind  <- TRUE
        } else if (a == "--timings") {
            do_timings  <- TRUE
        } else if (substr(a, 1, 15) == "--install-args=") {
            install_args <- substr(a, 16, 1000)
        } else if (substr(a, 1, 16) == "--check-subdirs=") {
            check_subdirs <- substr(a, 17, 1000)
        } else if (a == "--extra-arch") {
            extra_arch  <- TRUE
        } else if (a == "--multiarch") {
            multiarch  <- TRUE
        } else if (a == "--no-multiarch") {
            multiarch  <- FALSE
        } else if (a == "--force-multiarch") {
            force_multiarch  <- TRUE
        } else if (a == "--as-cran") {
            as_cran  <- TRUE
        } else if (substr(a, 1, 9) == "--rcfile=") {
            warning("configuration files are not supported as from R 2.12.0")
        } else if (substr(a, 1, 1) == "-") {
            message("Warning: unknown option ", sQuote(a))
        } else pkgs <- c(pkgs, a)
        args <- args[-1L]
    }

    ## record some of the options used.
    opts <- character()
    if (install == "fake") opts <- c(opts, "--install=fake")
    if (!do_install_arg) opts <- c(opts, "--no-install")
    if (install == "no") {
        opts <- c(opts, "--install=no")
        do_install_arg <- FALSE
    }

    if (install == "fake") {
        ## If we fake installation, then we cannot *run* any code.
        do_examples <- do_tests <- do_vignettes <- do_build_vignettes <- 0
        spec_install <- TRUE
        multiarch <- FALSE
    }

    if (!identical(multiarch, FALSE)) {
        ## see if there are multiple installed architectures, and if they work
        if (WINDOWS) {
            ## always has sub-archs as from R 2.12.0.
            ## usually if two are installed, it was done on a 64-bit OS,
            ## but the filesystem might be shared betweeen OSes.
            f <- dir(file.path(R.home(), "bin"))
            archs <- f[f %in% c("i386", "x64")]
            ## if we have x64, can only run it on a 64-bit OS
            if (length(archs) > 1L && !grepl("x64", utils:::win.version()))
                archs <- "i386"
        } else {
            wd2 <- setwd(file.path(R.home("bin"), "exec"))
            archs <- Sys.glob("*")
            setwd(wd2)
            if (length(archs) > 1L)
                for (arch in archs) {
                    if (arch == rarch) next
                    cmd <- paste0(file.path(R.home(), "bin", "R"),
                                  " --arch=", arch,
                                  " --version > /dev/null")
                    if (system(cmd)) archs <- archs[archs != arch]
                }
        }
        if (length(archs) <= 1L && isTRUE(multiarch))
            warning("'--multiarch' specified with only one usable sub-architecture",
                    call.=FALSE, immediate. = TRUE)
        multiarch <- length(archs) > 1L
    }


    ## Use system default unless explicitly specified otherwise.
    Sys.setenv(R_DEFAULT_PACKAGES="")

    ## Configurable variables
    R_check_use_install_log <-
        config_val_to_logical(Sys.getenv("_R_CHECK_USE_INSTALL_LOG_", "TRUE"))
    R_check_subdirs_nocase <-
        config_val_to_logical(Sys.getenv("_R_CHECK_SUBDIRS_NOCASE_", "TRUE"))
    R_check_all_non_ISO_C <-
        config_val_to_logical(Sys.getenv("_R_CHECK_ALL_NON_ISO_C_", "FALSE"))
    R_check_subdirs_strict <-
        Sys.getenv("_R_CHECK_SUBDIRS_STRICT_", "default")
    R_check_Rd_contents <-
        config_val_to_logical(Sys.getenv("_R_CHECK_RD_CONTENTS_", "TRUE"))
    R_check_Rd_line_widths <-
        config_val_to_logical(Sys.getenv("_R_CHECK_RD_LINE_WIDTHS_", "FALSE"))
    R_check_Rd_style <-
        config_val_to_logical(Sys.getenv("_R_CHECK_RD_STYLE_", "TRUE"))
    R_check_Rd_xrefs <-
        config_val_to_logical(Sys.getenv("_R_CHECK_RD_XREFS_", "TRUE"))
    R_check_use_codetools <-
        config_val_to_logical(Sys.getenv("_R_CHECK_USE_CODETOOLS_", "TRUE"))
    R_check_executables <-
        config_val_to_logical(Sys.getenv("_R_CHECK_EXECUTABLES_", "TRUE"))
    R_check_executables_exclusions <-
        config_val_to_logical(Sys.getenv("_R_CHECK_EXECUTABLES_EXCLUSIONS_", "TRUE"))
    R_check_permissions <-
        config_val_to_logical(Sys.getenv("_R_CHECK_PERMISSIONS_",
                                         as.character(.Platform$OS.type == "unix")))
    R_check_dot_internal <-
        config_val_to_logical(Sys.getenv("_R_CHECK_DOT_INTERNAL_", "TRUE"))
    R_check_depr_def <-
        config_val_to_logical(Sys.getenv("_R_CHECK_DEPRECATED_DEFUNCT_", "FALSE"))
    R_check_ascii_code <-
    	config_val_to_logical(Sys.getenv("_R_CHECK_ASCII_CODE_", "TRUE"))
    R_check_ascii_data <-
    	config_val_to_logical(Sys.getenv("_R_CHECK_ASCII_DATA_", "TRUE"))
     R_check_compact_data <-
    	config_val_to_logical(Sys.getenv("_R_CHECK_COMPACT_DATA_", "TRUE"))
    R_check_vc_dirs <-
    	config_val_to_logical(Sys.getenv("_R_CHECK_VC_DIRS_", "FALSE"))
    R_check_pkg_sizes <-
    	config_val_to_logical(Sys.getenv("_R_CHECK_PKG_SIZES_", "TRUE")) &&
        nzchar(Sys.which("du"))
    R_check_doc_sizes <-
    	config_val_to_logical(Sys.getenv("_R_CHECK_DOC_SIZES_", "TRUE")) &&
        nzchar(Sys.which(Sys.getenv("R_QPDF", "qpdf")))
    R_check_doc_sizes2 <-
    	config_val_to_logical(Sys.getenv("_R_CHECK_DOC_SIZES2_", "FALSE"))
    R_check_code_assign_to_globalenv <-
        config_val_to_logical(Sys.getenv("_R_CHECK_CODE_ASSIGN_TO_GLOBALENV_",
                                         "FALSE"))
    R_check_code_attach <-
        config_val_to_logical(Sys.getenv("_R_CHECK_CODE_ATTACH_", "FALSE"))
    R_check_code_data_into_globalenv <-
        config_val_to_logical(Sys.getenv("_R_CHECK_CODE_DATA_INTO_GLOBALENV_",
                                         "FALSE"))

    ## Only relevant when the package is loaded, thus installed.
    R_check_suppress_RandR_message <-
        do_install_arg && config_val_to_logical(Sys.getenv("_R_CHECK_SUPPRESS_RANDR_MESSAGE_", "TRUE"))
    R_check_force_suggests <-
        config_val_to_logical(Sys.getenv("_R_CHECK_FORCE_SUGGESTS_", "TRUE"))
    R_check_skip_tests_arch <-
        unlist(strsplit(Sys.getenv("_R_CHECK_SKIP_TESTS_ARCH_"), ",")[[1]])
    R_check_skip_examples_arch <-
        unlist(strsplit(Sys.getenv("_R_CHECK_SKIP_EXAMPLES_ARCH_"), ",")[[1]])
    R_check_skip_arch <-
        unlist(strsplit(Sys.getenv("_R_CHECK_SKIP_ARCH_"), ",")[[1]])
    R_check_unsafe_calls <-
        config_val_to_logical(Sys.getenv("_R_CHECK_UNSAFE_CALLS_", "TRUE"))
    R_check_depends_only <-
        config_val_to_logical(Sys.getenv("_R_CHECK_DEPENDS_ONLY_", "FALSE"))
    R_check_suggests_only <-
        config_val_to_logical(Sys.getenv("_R_CHECK_SUGGESTS_ONLY_", "FALSE"))
    R_check_FF <- Sys.getenv("_R_CHECK_FF_CALLS_", "true")
    R_check_FF_DUP <-
        config_val_to_logical(Sys.getenv("_R_CHECK_FF_DUP_", "TRUE"))
    R_check_toplevel_files <-
        config_val_to_logical(Sys.getenv("_R_CHECK_TOPLEVEL_FILES_", "FALSE"))

    if (!nzchar(check_subdirs)) check_subdirs <- R_check_subdirs_strict

    if (as_cran) {
        if (extra_arch) {
            message("'--as-cran' turns off '--extra-arch'")
            extra_arch <- FALSE
        }
        Sys.setenv("_R_CHECK_TIMINGS_" = "10")
        Sys.setenv("_R_CHECK_INSTALL_DEPENDS_" = "TRUE")
        Sys.setenv("_R_CHECK_NO_RECOMMENDED_" = "TRUE")
        Sys.setenv("_R_SHLIB_BUILD_OBJECTS_SYMBOL_TABLES_" = "TRUE")
        Sys.setenv("_R_CHECK_DOT_FIRSTLIB_" = "TRUE")
        Sys.setenv("_R_CHECK_PACKAGES_USED_CRAN_INCOMING_NOTES_" = "TRUE")
        prev <- Sys.getenv("_R_CHECK_LIMIT_CORES_", NA)
        if(is.na(prev)) Sys.setenv("_R_CHECK_LIMIT_CORES_" = "TRUE")
        prev <- Sys.getenv("_R_CHECK_SCREEN_DEVICE_", NA)
        if(is.na(prev)) Sys.setenv("_R_CHECK_SCREEN_DEVICE_" = "stop")
        R_check_vc_dirs <- TRUE
        R_check_executables_exclusions <- FALSE
        R_check_doc_sizes2 <- TRUE
        R_check_suggests_only <- TRUE
        R_check_code_assign_to_globalenv <- TRUE
        R_check_code_attach <- TRUE
        R_check_code_data_into_globalenv <- TRUE
        R_check_depr_def <- TRUE
        R_check_Rd_line_widths <- TRUE
        R_check_FF <- "registration"
        do_timings <- TRUE
        R_check_toplevel_files <- TRUE
    } else {
        ## do it this way so that INSTALL produces symbols.rds
        ## when called from check but not in general.
        if(is.na(Sys.getenv("_R_SHLIB_BUILD_OBJECTS_SYMBOL_TABLES_", NA)))
            Sys.setenv("_R_SHLIB_BUILD_OBJECTS_SYMBOL_TABLES_" = "TRUE")
    }


    if (extra_arch) {
        R_check_Rd_contents <- R_check_all_non_ISO_C <-
            R_check_Rd_xrefs <- R_check_use_codetools <- R_check_Rd_style <-
                R_check_executables <- R_check_permissions <-
                    R_check_dot_internal <- R_check_ascii_code <-
                    	R_check_ascii_data <- R_check_compact_data <-
                            R_check_pkg_sizes <- R_check_doc_sizes <-
                                R_check_doc_sizes2 <-
                                    R_check_unsafe_calls <-
                                        R_check_toplevel_files <- FALSE
        R_check_Rd_line_widths <- FALSE
    }

    startdir <- getwd()
    if (is.null(startdir))
        stop("current working directory cannot be ascertained")
    if (!nzchar(outdir)) outdir <- startdir
    setwd(outdir)
    outdir <- getwd()
    setwd(startdir)

    R_LIBS <- Sys.getenv("R_LIBS")
    arg_libdir <- libdir
    if (nzchar(libdir)) {
        setwd(libdir)
        libdir <- getwd()
        Sys.setenv(R_LIBS = env_path(libdir, R_LIBS))
        setwd(startdir)
    }

    ## all the analysis code is run with --slave
    ## examples and tests are not.
    R_opts <- "--vanilla"
    R_opts2 <- "--vanilla --slave"
    ## do run Renviron.site for some multiarch runs
    ## We set R_ENVIRON_USER to skip .Renviron files.
    R_opts3 <- "--no-site-file --no-init-file --no-save --no-restore"
    R_opts4 <- "--no-site-file --no-init-file --no-save --no-restore --slave"
    env0 <- if(WINDOWS) "R_ENVIRON_USER='no_such_file'" else "R_ENVIRON_USER=''"

    msg_DESCRIPTION <- c("See the information on DESCRIPTION files",
                         " in the chapter 'Creating R packages'",
                         " of the 'Writing R Extensions' manual.\n")

    if (!length(pkgs)) {
        message("Error: no packages were specified")
        do_exit(1L)
    }

    ## This is the main loop over all packages to be checked.
    for (pkg in pkgs) {
        ## pkg should be the path to the package root source
        ## directory, either absolute or relative to startdir.
        ## As from 2.1.0 it can also be a tarball

        ## The previous package may have set do_install to FALSE
        do_install <- do_install_arg
        no_examples <- FALSE

        ## $pkgdir is the corresponding absolute path.
        ## pkgname0 is the name of the top-level directory
        ## (and often the name of the package).
        setwd(startdir)
        pkg <- sub("/$", "", pkg)       # strip any trailing '/'
        pkgname0 <- basename(pkg)
        is_ascii <- FALSE

        thispkg_subdirs <- check_subdirs
        ## is this a tar archive?
        if (dir.exists(pkg)) {
            istar <- FALSE
            if (thispkg_subdirs == "default") thispkg_subdirs <- "no"
        } else if (file.exists(pkg)) {
            istar <- TRUE
            if (thispkg_subdirs == "default") thispkg_subdirs <- "yes-maybe"
            pkgname0 <- sub("\\.(tar\\.gz|tgz|tar\\.bz2|tar\\.xz)$", "", pkgname0)
            pkgname0 <- sub("_[0-9.-]*$", "", pkgname0)
        } else {
            warning(sQuote(pkg), " is neither a file nor directory, skipping\n",
                    domain = NA, call. = FALSE, immediate. = TRUE)
            next
        }
        pkgoutdir <- file.path(outdir, paste(pkgname0, "Rcheck", sep = "."))
        if (clean && dir.exists(pkgoutdir)) {
            unlink(pkgoutdir, recursive = TRUE)
            if(WINDOWS) Sys.sleep(0.5) # allow for antivirus interference
        }
        dir.create(pkgoutdir, mode = "0755")
        if (!dir.exists(pkgoutdir)) {
            message(sprintf("ERROR: cannot create check dir %s", sQuote(pkgoutdir)))
            do_exit(1L)
        }
        Log <- newLog(file.path(pkgoutdir, "00check.log"))
        if (istar) {
            dir <- file.path(pkgoutdir, "00_pkg_src")
            dir.create(dir, mode = "0755")
            if (!dir.exists(dir)) {
                errorLog(Log, sprintf("cannot create %s", sQuote(dir)))
                do_exit(1L)
            }
            ## force the use of internal untar unless over-ridden
            ## so e.g. .tar.xz works everywhere
            if (untar(pkg, exdir = dir,
                      tar =  Sys.getenv("R_INSTALL_TAR", "internal"))) {
                errorLog(Log, sprintf("cannot unpack %s", sQuote(pkg)))
                do_exit(1L)
            }
            ## this assumes foo_x.y.tar.gz unpacks to foo, but we are about
            ## to test that.
            pkg <- file.path(dir, pkgname0)
        }
        if (!dir.exists(pkg))
            stop(gettextf("package directory %s does not exist",
                          sQuote(pkg)), domain = NA)
        setwd(pkg)
        pkgdir <- getwd()
        thispkg_src_subdirs <- thispkg_subdirs
        if (thispkg_src_subdirs == "yes-maybe") {
            ## now see if there is a 'configure' file
            ## configure files are only used if executable, but
            ## -x is always false on Windows.
            if (WINDOWS) {
                if (file_test("-f", "configure")) thispkg_src_subdirs <- "no"
            } else {
                if (file_test("-x", "configure")) thispkg_src_subdirs <- "no"
            }
        }
        setwd(startdir)

        messageLog(Log, "using log directory ", sQuote(pkgoutdir))
        messageLog(Log, "using ", R.version.string)
        messageLog(Log, "using platform: ", R.version$platform,
                   " (", 8*.Machine$sizeof.pointer, "-bit)")
        charset <-
            if (l10n_info()[["UTF-8"]]) "UTF-8" else utils::localeToCharset()
        messageLog(Log, "using session charset: ", charset)
        is_ascii <- charset == "ASCII"

        .unpack.time <- Sys.time()

        ## report options used
        if (!do_codoc) opts <- c(opts, "--no-codoc")
        if (!do_examples && !spec_install) opts <- c(opts, "--no-examples")
        if (!do_tests && !spec_install) opts <- c(opts, "--no-tests")
        if (!do_vignettes && !spec_install) opts <- c(opts, "--no-vignettes")
        if (!do_build_vignettes && !spec_install)
            opts <- c(opts, "--no-build-vignettes")
        if (use_gct) opts <- c(opts, "--use-gct")
        if (use_valgrind) opts <- c(opts, "--use-valgrind")
        if (length(opts) > 1L)
            messageLog(Log, "using options ", sQuote(paste(opts, collapse=" ")))
        else if (length(opts) == 1L)
            messageLog(Log, "using option ", sQuote(opts))

        if (!nzchar(libdir)) {
            libdir <- pkgoutdir
            Sys.setenv(R_LIBS = env_path(libdir, R_LIBS))
        }
        if (WINDOWS && grepl(" ", libdir)) # need to avoid spaces in libdir
            libdir <- gsub("\\", "/", shortPathName(libdir), fixed = TRUE)

        ## Package sources from the R distribution are special.  They
        ## have a 'DESCRIPTION.in' file (instead of 'DESCRIPTION'),
        ## with Version and License fields containing '@VERSION@' for
        ## substitution by configure.  Earlier bundles had packages
        ## containing DESCRIPTIION.in, hence the extra check for
        ## Makefile.in.

        is_base_pkg <- is_rec_pkg <- FALSE
        if (file.exists(f <- file.path(pkgdir, "DESCRIPTION.in")) &&
            file.exists(file.path(pkgdir, "Makefile.in"))) {
            desc <- try(read.dcf(f))
            if (inherits(desc, "try-error") || !length(desc)) {
                resultLog(Log, "EXISTS but not correct format")
                do_exit(1L)
            }
            desc <- desc[1L, ]
            if (desc["Priority"] == "base") {
                messageLog(Log, "looks like ", sQuote(pkgname0),
                           " is a base package")
                messageLog(Log, "skipping installation test")
                is_base_pkg <- TRUE
                pkgname <- desc["Package"] # should be same as pkgname0
            }
        }

        this_multiarch <- multiarch
        if (!is_base_pkg) {
            desc <- check_description()
            pkgname <- desc["Package"]
            is_rec_pkg <- desc["Priority"] %in% "recommended"

            ## Check if we have any hope of installing
            OS_type <- desc["OS_type"]
            if (do_install && !is.na(OS_type)) {
                if (WINDOWS && OS_type != "windows") {
                    messageLog(Log, "will not attempt to install this package on Windows")
                    do_install <- FALSE
                }
                if (!WINDOWS && OS_type == "windows") {
                    messageLog(Log, "this is a Windows-only package, skipping installation")
                    do_install <- FALSE
                }
            } else OS_type <- NA

            check_incoming <- Sys.getenv("_R_CHECK_CRAN_INCOMING_", "NA")
            check_incoming <- if(check_incoming == "NA") as_cran else {
                config_val_to_logical(check_incoming)
            }
            if (check_incoming) check_CRAN_incoming()

            ## <NOTE>
            ## We want to check for dependencies early, since missing
            ## dependencies may make installation fail, and in any case we
            ## give up if they are missing.  But we don't check them if
            ## we are not going to install and hence not run any code.
            ## </NOTE>
            if (do_install) {
                topfiles0 <- dir(pkgdir)
                check_dependencies()
            } else topfiles0 <- NULL

            check_sources()
            checkingLog(Log, "if there is a namespace")
            ## careful: we need a case-sensitive match
            if ("NAMESPACE" %in% dir(pkgdir))
                resultLog(Log, "OK")
            else  if (file.exists(file.path(pkgdir, "NAMESPACE"))) {
                errorLog(Log,
                       "File NAMESPACE does not exist but there is a case-insenstiive match.")
                do_exit(1L)
            } else if (dir.exists(file.path(pkgdir, "R"))) {
                errorLog(Log)
                wrapLog("All packages need a namespace as from R 3.0.0.\n",
                        "R CMD build will produce a suitable starting point,",
                        "but it is better to handcraft a NAMESPACE file.")
                do_exit(1L)
            } else {
                noteLog(Log)
                wrapLog("Packages without R code can be installed without",
                        "a NAMESPACE file, but it is cleaner to add",
                        "an empty one.")
            }

            ## we need to do this before installation
            if (R_check_executables) check_executables()
            ## (Alternatively, could use .unpack.time.)

            check_dot_files(check_incoming)

	    setwd(pkgdir)
            allfiles <- check_file_names()
            if (R_check_permissions) check_permissions(allfiles)
	    setwd(startdir)

            ## record this before installation.
            ## <NOTE>
            ## Could also teach the code to check 'src/Makevars[.in]'
            ## files to use .unpack.time.
            ## (But we want to know if the sources contain
            ## 'src/Makevars' and INSTALL re-creates this.)
            ## </NOTE>
            makevars <-
                Sys.glob(file.path(pkgdir, "src",
                                   c("Makevars.in", "Makevars")))
            makevars <- basename(makevars)

            if (do_install) {
                check_install()
                if(R_check_pkg_sizes) check_install_sizes()
            }
            if (multiarch) {
                if (force_multiarch) inst_archs <- archs
                else {
                    ## check which architectures this package is installed for
                    if (dir.exists(dd <- file.path(libdir, pkgname, "libs"))) {
                        inst_archs <- dir(dd)
                        ## xlsReadWrite has spurious subdir 'template'
                        inst_archs <- inst_archs[inst_archs %in% archs]
                        if (!identical(inst_archs, archs)) {
                            if (length(inst_archs) > 1)
				printLog0(Log,
                                          "NB: this package is only installed for sub-architectures ",
                                          paste(sQuote(inst_archs), collapse=", "), "\n")
			    else {
				printLog0(Log,
                                          "NB: this package is only installed for sub-architecture ",
                                          sQuote(inst_archs), "\n")
                                if(inst_archs == .Platform$r_arch)
                                    this_multiarch <- FALSE
                            }
                        }
                    } else this_multiarch <- FALSE  # no compiled code
                }
                if (this_multiarch && length(R_check_skip_arch))
                    inst_archs <- inst_archs[!(inst_archs %in% R_check_skip_arch)]
            }
        }   ## end of if (!is_base_pkg)

        elibs <- if(is_base_pkg) character()
        else if(R_check_depends_only)
            setRlibs(pkgdir = pkgdir, libdir = libdir)
        else if(R_check_suggests_only)
            setRlibs(pkgdir = pkgdir, libdir = libdir, suggests = TRUE)
        else character()

        setwd(startdir)
        check_pkg(pkgdir, pkgname, pkgoutdir, startdir, libdir, desc,
                  is_base_pkg, is_rec_pkg, thispkg_subdirs, extra_arch)
        if (!extra_arch && do_manual) {
            setwd(pkgoutdir)
            instdir <- file.path(libdir, pkgname)
            if (dir.exists(file.path(instdir, "help")))
                check_pkg_manual(instdir, desc["Package"])
            else
                check_pkg_manual(pkgdir, desc["Package"])
        }

        if (!is_base_pkg && check_incoming && no_examples &&
            dir.exists(file.path(pkgdir, "R"))) {
           tests_dir <- file.path(pkgdir, "tests")
            if (dir.exists(tests_dir) &&
                length(dir(tests_dir, pattern = "\\.(R|Rin)$")))
                no_examples <- FALSE
            vigns <- pkgVignettes(dir = pkgdir)
            if (!is.null(vigns) && length(vigns$docs)) no_examples <- FALSE
            if (no_examples) {
                ## figure out if the R code exercises anything
                ns <- parseNamespaceFile(basename(pkgdir), dirname(pkgdir))
                if(length(ns$exports) || length(ns$exportPatterns) ||
                   length(ns$exportMethods) || length(ns$S3methods)) {
                    checkingLog(Log, "for code which exercises the package")
                    warningLog(Log, "No examples, no tests, no vignettes")
                }
            }
        }
        if ((Log$warnings > 0L) || (Log$notes > 0L)) {
            message(""); summaryLog(Log)
        }

        if(config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_STATUS_SUMMARY_",
                                            "FALSE"))) {
            s <- summarize_CRAN_check_status(pkgname)
            if(nzchar(s)) {
                writeLines(c("", s), Log$con)
            }
        }

        closeLog(Log)
        message("")

    } ## end for (pkg in pkgs)

} ## end{ .check_packages }

.format_lines_with_indent <-
function(x)
    paste0("  ", x, collapse = "\n")
    ## Hard-wire indent of 2 for now.


summarize_CRAN_check_status <-
function(package, results = NULL, details = NULL, mtnotes = NULL)
{
    if(is.null(results))
        results <- CRAN_check_results()
    results <-
        results[!is.na(match(results$Package, package)) & !is.na(results$Status), ]

    if(!NROW(results)) {
        s <- character(length(package))
        names(s) <- package
        return(s)
    }

    if(any(results$Status != "OK")) {
        if(is.null(details))
            details <- CRAN_check_details()
        details <- details[!is.na(match(details$Package, package)), ]
        ## Remove trailing white space from outputs ... remove eventually
        ## when this is done on CRAN.
        details$Output <- sub("[[:space:]]+$", "", details$Output)

    } else {
        ## Create empty details directly to avoid the cost of reading
        ## and subscripting the actual details db.
        details <- as.data.frame(matrix(character(), ncol = 7L),
                                 stringsAsFactors = FALSE)
        names(details) <-
            c("Package", "Version", "Flavor", "Check", "Status", "Output",
              "Flags")
    }

    if(is.null(mtnotes))
        mtnotes <- CRAN_memtest_notes()


    summarize_results <- function(p, r) {
        if(!NROW(r)) return(character())
        tab <- table(r$Status)[c("ERROR", "WARN", "NOTE", "OK")]
        tab <- tab[!is.na(tab)]
        paste(c(sprintf("Current CRAN status: %s",
                        paste(sprintf("%s: %s", names(tab), tab),
                              collapse = ", ")),
                sprintf("See: <http://CRAN.R-project.org/web/checks/check_results_%s.html>",
                        p)),
              collapse = "\n")
    }

    summarize_details <- function(p, d) {
        if(!NROW(d)) return(character())
        pos <- which(names(d) == "Flavor")
        txt <- apply(d[-pos], 1L, paste, collapse = "\r")
        ## Outputs from checking "installed package size" will vary
        ## according to system.
        ind <- d$Check == "installed package size"
        if(any(ind)) {
            pos <- c(pos, which(names(d) == "Output"))
            txt[ind] <- apply(d[ind, -pos], 1L, paste, collapse = "\r")
        }

        ## Regularize fancy quotes.
        ## Could also try using iconv(to = "ASCII//TRANSLIT"))
        txt <- gsub("(\xe2\x80\x98|\xe2\x80\x99)", "'", txt,
                    perl = TRUE, useBytes = TRUE)
        txt <- gsub("(\xe2\x80\x9c|\xe2\x80\x9d)", '"', txt,
                    perl = TRUE, useBytes = TRUE)
        out <-
            lapply(split(seq_len(NROW(d)), match(txt, unique(txt))),
                   function(e) {
                       tmp <- d[e[1L], ]
                       flags <- tmp$Flags
                       flavors <- d$Flavor[e]
                       c(sprintf("Version: %s", tmp$Version),
                         if(nzchar(flags)) sprintf("Flags: %s", flags),
                         sprintf("Check: %s, Result: %s", tmp$Check, tmp$Status),
                         sprintf("  %s",
                                 gsub("\n", "\n  ", tmp$Output,
                                      perl = TRUE, useBytes = TRUE)),
                         sprintf("See: %s",
                                 paste(sprintf("<http://www.r-project.org/nosvn/R.check/%s/%s-00check.html>",
                                               flavors,
                                               p),
                                       collapse = ",\n     ")))
                   })
        paste(unlist(lapply(out, paste, collapse = "\n")),
              collapse = "\n\n")
    }

    summarize_mtnotes <- function(p, m) {
        if(!length(m)) return(character())
        tests <- m[, "Test"]
        paths <- m[, "Path"]
        isdir <- !grepl("-Ex.Rout$", paths)
        if(any(isdir))
            paths[isdir] <- sprintf("%s/", paths[isdir])
        paste(c(paste("Memtest notes:",
                      paste(unique(tests), collapse = " ")),
                sprintf("See: %s",
                        paste(sprintf("<http://www.stats.ox.ac.uk/pub/bdr/memtests/%s/%s>",
                                      tests,
                                      paths),
                              collapse = ",\n     "))),
              collapse = "\n")
    }

    summarize <- function(p, r, d, m) {
        paste(c(summarize_results(p, r),
                summarize_mtnotes(p, m),
                summarize_details(p, d)),
              collapse = "\n\n")
    }

    s <- if(length(package) == 1L) {
        summarize(package, results, details, mtnotes[[package]])
    } else {
        results <- split(results, factor(results$Package, package))
        details <- split(details, factor(details$Package, package))
        unlist(lapply(package,
                      function(p) {
                          summarize(p,
                                    results[[p]],
                                    details[[p]],
                                    mtnotes[[p]])
                      }))
    }

    names(s) <- package
    class(s) <- "summarize_CRAN_check_status"
    s
}

format.summarize_CRAN_check_status <-
function(x, header = NA, ...)
{
    if(is.na(header)) header <- (length(x) > 1L)
    if(header) {
        s <- sprintf("Package: %s", names(x))
        x <- sprintf("%s\n%s\n\n%s", s, gsub(".", "*", s), x)
    }
    x
}

print.summarize_CRAN_check_status <-
function(x, ...)
{
    writeLines(paste(format(x, ...), collapse = "\n\n"))
    invisible(x)
}


CRAN_check_results <-
function()
{
    rds <- gzcon(url(sprintf("%s/%s",
                             getOption("repos")["CRAN"],
                             "web/checks/check_results.rds"),
                     open = "rb"))
    ## We could make the location of the local CRAN web/checks rsync
    ## settable via some env var.
    results <- readRDS(rds)
    close(rds)

    results
}

CRAN_check_details <-
function()
{
    rds <- gzcon(url(sprintf("%s/%s",
                             getOption("repos")["CRAN"],
                             "web/checks/check_details.rds"),
                     open = "rb"))
    ## We could make the location of the local CRAN web/checks rsync
    ## settable via some env var.
    details <- readRDS(rds)
    close(rds)

    details
}

CRAN_memtest_notes <-
function()
{
    rds <- gzcon(url(sprintf("%s/%s",
                             getOption("repos")["CRAN"],
                             "web/checks/memtest_notes.rds"),
                     open = "rb"))
    ## We could make the location of the local CRAN web/checks rsync
    ## settable via some env var.
    mtnotes <- readRDS(rds)
    close(rds)

    mtnotes
}

### Local variables:
### mode: R
### page-delimiter: "^###[#-]"
### End:
#  File src/library/tools/R/checktools.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 2013-2013 The R 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 of the License, 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/

check_packages_in_dir <-
function(dir,
         check_args = character(), check_args_db = list(),
         reverse = NULL,
         check_env = character(),
         xvfb = FALSE,
         Ncpus = getOption("Ncpus", 1L),
         clean = TRUE,
         ...)
{
    owd <- getwd()
    dir <- normalizePath(dir)
    setwd(dir)
    on.exit(setwd(owd))

    pfiles <- Sys.glob("*.tar.gz")
    if(!length(pfiles)) {
        message("no packages to check")
        return(invisible())
    }
    pnames <- sub("_.*", "", pfiles)

    os_type <- .Platform$OS.type

    ## Xvfb usage and options.
    ## We do not use Xvfb on Windows.
    ## Otherwise, if argument 'xvfb' is
    ## * a logical, Xvfb is used only if identical to TRUE;
    ## * something else, then as.character(xvfb) gives the Xvfb options.
    xvfb_options <- "-screen 0 1280x1024x24"
    if(os_type == "windows")
        xvfb <- FALSE
    else if(is.logical(xvfb)) {
        if(!identical(xvfb, TRUE))
            xvfb <- FALSE
    } else {
        xvfb_options <- as.character(xvfb)
        xvfb <- TRUE
    }
    
    curl <- if(os_type == "windows") 
        sprintf("file:///%s", dir)
    else
        sprintf("file://%s", dir)

    libdir <- file.path(dir, "Library")
    dir.create(libdir, showWarnings = FALSE)
    outdir <- file.path(dir, "Outputs")
    dir.create(outdir, showWarnings = FALSE)

    ## Determine packages using fake/no install for checking.
    ## Handle these as follows:
    ## * For packages using '--install=no', forward dependencies do not
    ##   need to installed, and reverse dependencies do not need to be
    ##   checked.
    ## * For packages using '--install=fake', forward dependencies must
    ##   be available for checking, and checking reverse dependencies
    ##   makes sense (e.g, to spot missing Rd xrefs).
    pnames_using_install_no <- character()
    pnames_using_install_fake <- character()
    check_args_db <- as.list(check_args_db)
    if(length(check_args_db) &&
       !is.null(nms <- names(check_args_db))) {
        args <- lapply(check_args_db,
                       function(e)
                       scan(text = e, what = character(), quiet = TRUE))
        pnames_using_install_no <-
            nms[sapply(args, function(e) any(e == "--install=no"))]
        pnames_using_install_fake <-
            nms[sapply(args, function(e) any(e == "--install=fake"))]
    } else {
        ## If check_args_db has no names it is useless.
        ## Perhaps complain?
        check_args_db <- list()
    }

    ## Build a package db from the source packages in the working
    ## directory.
    write_PACKAGES(dir, type = "source")
    
    curls <- c(curl,
               utils::contrib.url(getOption("repos"), type = "source"))
    available <- utils::available.packages(contriburl = curls,
                                           type = "source")

    ## As of c52164, packages with OS_type different from the current
    ## one are *always* checked with '--install=no'.
    ## These packages are also filtered out by default (via the OS_type
    ## filter) from the repository package computations.
    ## Hence move packages in the install=fake list not listed by
    ## available.packages() to the install=no list.
    pnames_using_install_no <-
        c(pnames_using_install_no,
          setdiff(pnames_using_install_fake, available[, "Package"]))
    pnames_using_install_fake <-
        intersect(pnames_using_install_fake, available[, "Package"])
    
    if(!is.null(reverse) && !identical(reverse, FALSE)) {
        ## Determine and download reverse dependencies to be checked as
        ## well.
        
        reverse <- as.list(reverse)
        ## Merge with defaults, using partial name matching.
        defaults <- list(which = c("Depends", "Imports", "LinkingTo"),
                         recursive = FALSE,
                         repos = getOption("repos"))
        pos <- pmatch(names(reverse), names(defaults), nomatch = 0L)
        defaults[pos] <- reverse[pos > 0L]

        rnames <- if(is.list(defaults$which)) {
            ## No recycling of repos for now.
            defaults$recursive <- rep_len(as.list(defaults$recursive),
                                          length(defaults$which))
            unlist(Map(function(w, r)
                       package_dependencies(setdiff(pnames,
                                                    pnames_using_install_no),
                                            available,
                                            which = w,
                                            recursive = r,
                                            reverse = TRUE),
                       defaults$which,
                       defaults$recursive),
                   use.names = FALSE)
        } else {
            package_dependencies(setdiff(pnames,
                                         pnames_using_install_no),
                                 available,
                                 which = defaults$which,
                                 recursive = defaults$recursive,
                                 reverse = TRUE)
        }

        rnames <- intersect(unlist(rnames, use.names = FALSE),
                            available[, "Package"])
        rnames <- setdiff(rnames, pnames)

        pos <- match(rnames, available[, "Package"], nomatch = 0L)
        if(!identical(defaults$repos, getOption("repos"))) {
            pos <- split(pos[pos > 0L], available[pos, "Repository"])
            ## Only want the reverse dependencies for which Repository
            ## is pmatched by contrib.url(defaults$repos).
            nms <- names(pos)
            pos <- unlist(pos[unique(c(outer(defaults$repos, nms,
                                             pmatch, nomatch = 0L)))],
                          use.names = FALSE)
        }
        rnames <- available[pos, "Package"]
        rfiles <- sprintf("%s_%s.tar.gz",
                          rnames,
                          available[pos, "Version"])

        if(length(rfiles)) {
            message("downloading reverse dependencies ...")
            rfurls <- sprintf("%s/%s",
                              available[pos, "Repository"],
                              rfiles)
            for(i in seq_along(rfiles)) {
                message(sprintf("downloading %s ... ", rfiles[i]),
                        appendLF = FALSE)
                status <- if(!utils::download.file(rfurls[i], rfiles[i]))
                    "ok" else "failed"
                message(status)
            }
            message("")
        }

    } else {
        rfiles <- rnames <- character()
    }

    pnames <- c(pnames, rnames)

    ## Install what is needed.

    depends <-
        package_dependencies(pnames, available, which = "most")
    depends <- setdiff(unique(unlist(depends, use.names = FALSE)),
                       unlist(.get_standard_package_names(),
                              use.names = FALSE))

    ## Need to install depends which are not installed or installed but
    ## old.
    libs <- c(libdir, .libPaths())
    installed <- utils::installed.packages(libs)[, "Package"]
    depends <-
        c(setdiff(depends, installed),
          intersect(intersect(depends, installed),
                    utils::old.packages(libs, contriburl = curls)[, "Package"]))
    if(length(depends)) {
        message(paste(strwrap(sprintf("installing dependencies %s",
                                      paste(sQuote(depends),
                                            collapse = ", ")),
                              exdent = 2L),
                      collapse = "\n"))
        ## <NOTE>
        ## Ideally we would capture stdout and stderr in e.g.
        ##   outdir/install_stdout.txt
        ##   outdir/install_stderr.txt
        ## But using several CPUs uses Make to install, which seems to
        ## write to stdout/stderr "directly" ... so using sink() will
        ## not work.  Hence, use 'keep_outputs' to capture "outputs"
        ## (combining install stdout and stderr into one file).
        message("")
        iflags <- as.list(rep.int("--fake",
                                  length(pnames_using_install_fake)))
        names(iflags) <- pnames_using_install_fake
        tmpdir <- tempfile(tmpdir = outdir)
        dir.create(tmpdir)
        utils::install.packages(depends, lib = libdir,
                                contriburl = curls,
                                available = available,
                                dependencies = TRUE,
                                INSTALL_opts = iflags,
                                keep_outputs = tmpdir,
                                Ncpus = Ncpus, 
                                type = "source")
        outfiles <- Sys.glob(file.path(tmpdir, "*.out"))
        file.rename(outfiles,
                    file.path(outdir,
                              sprintf("install_%s",
                                      basename(outfiles))))
        unlink(tmpdir, recursive = TRUE)
        message("")
        ## </NOTE>
    }

    ## Merge check_args and check_args_db into check_args_db used for
    ## checking.
    check_args <- if(is.list(check_args)) {
        c(rep.int(list(check_args[[1L]]), length(pfiles)),
          rep.int(list(check_args[[2L]]), length(rfiles)))
    } else {
        rep.int(list(check_args), length(pnames))
    }
    check_args_db <- check_args_db[pnames]
    check_args_db <- Map(c, check_args, check_args_db)
    names(check_args_db) <- pnames

    check_env <- if(is.list(check_env)) {
        c(rep.int(list(check_env[[1L]]), length(pfiles)),
          rep.int(list(check_env[[2L]]), length(rfiles)))
    } else {
        rep.int(list(check_env), length(pnames))
    }
    ## No user level check_env_db for now.
    check_env_db <- as.list(check_env)
    names(check_env_db) <- pnames

    pfiles <- c(pfiles, rfiles)

    check_package <- function(pfile, args_db = NULL, env_db = NULL) {
        message(sprintf("checking %s ...", pfile))
        pname <- sub("_.*", "", basename(pfile))
        out <- file.path(outdir,
                         sprintf("check_%s_stdout.txt", pname))
        err <- file.path(outdir,
                         sprintf("check_%s_stderr.txt", pname))
        env <- c(check_env_db[[pname]],
                 sprintf("R_LIBS=%s", shQuote(libdir)))
        system.time(system2(file.path(R.home("bin"), "R"),
                            c("CMD",
                              "check",
                              "--timings",
                              args_db[[pname]],
                              pfile),
                            stdout = out,
                            stderr = err,
                            env = env))
    }


    if(xvfb) {
        pid <- start_virtual_X11_fb(xvfb_options)
        on.exit(close_virtual_X11_db(pid), add = TRUE)
    }

    if(Ncpus > 1L) {
        if(os_type != "windows") {
            timings <- parallel::mclapply(pfiles,
                                          check_package,
                                          check_args_db,
                                          check_env_db,
                                          mc.cores = Ncpus)
        } else {
            cl <- parallel::makeCluster(Ncpus)
            timings <- parallel::parLapply(cl,
                                           pfiles,
                                           check_package,
                                           check_args_db,
                                           check_env_db)
            parallel::stopCluster(cl)
        }
    } else {
        timings <- lapply(pfiles,
                          check_package,
                          check_args_db,
                          check_env_db)
    }

    timings <- do.call(rbind, lapply(timings, summary))
    rownames(timings) <- pnames
    write.table(timings, "timings.tab")

    file.rename(sprintf("%s.Rcheck", rnames),
                sprintf("rdepends_%s.Rcheck", rnames))

    if(clean) {
        file.remove(rfiles)
    } else {
        file.rename(rfiles, sprintf("rdepends_%s", rfiles))
    }

    invisible(pfiles)

}

start_virtual_X11_fb <-
function(options)
{
    ## Determine the display number from the options, or the PID of the
    ## current R process (alternatively, could mimic xvfb-run).
    args <- scan(text = options, what = character(), quiet = TRUE)
    ind <- grepl("^:[[:digit:]]+$", args)
    if(any(ind)) {
        num <- args[ind][1L]
    } else {
        num <- paste0(":", Sys.getpid())
        options <- c(num, options)
    }

    dis <- Sys.getenv("DISPLAY", unset = NA)

    ## We need to start Xvfb with the given options and obtain its pid
    ## so that we can terminate it when done checking.
    ## This could be done via
    ##   system2("Xvfb", options, stdout = FALSE, stderr = FALSE,
    ##           wait = FALSE)
    ## and then determine the pid as 
    ##   pid <- scan(text =
    ##               grep(sprintf("Xvfb %s", num),
    ##                    system2("ps", "auxw", stdout = TRUE),
    ##                    value = TRUE,
    ##                    fixed = TRUE),
    ##               what = character(),
    ##               quiet = TRUE)[2L]
    ## A better approach (suggested by BDR) is to create a shell script
    ## containing the call to start Xvfb in the background and display
    ## the pid of this as available in the shell's $! parameter.
    tf <- tempfile()
    on.exit(unlink(tf))
    writeLines(c(paste(c(shQuote("Xvfb"), options, ">/dev/null 2>&1 &"),
                       collapse = " "),
                 "echo ${!}"),
               tf)
    pid <- system2("sh", tf, stdout = TRUE)
    Sys.setenv("DISPLAY" = num)
    
    ## Propagate both pid and original setting of DISPLAY so that the
    ## latter can be restored when Xvfb is closed.
    attr(pid, "display") <- dis
    pid
}

close_virtual_X11_db <-
function(pid)
{
    pskill(pid)
    if(is.na(dis <- attr(pid, "display")))
        Sys.unsetenv("DISPLAY")
    else
        Sys.setenv("DISPLAY" = dis)
}

R_check_outdirs <-
function(dir, all = FALSE)
{
    dir <- normalizePath(dir)
    outdirs <- dir(dir, pattern = "\\.Rcheck")
    if(!all) outdirs <- outdirs[!grepl("^rdepends_", outdirs)]
    file.path(dir, outdirs)
}

summarize_check_packages_in_dir_depends <-
function(dir, all = FALSE)
{
    for(d in R_check_outdirs(dir, all = all)) {
        dfile <- Sys.glob(file.path(d, "00_pkg_src", "*",
                                    "DESCRIPTION"))[1L]
        if(file_test("-f", dfile)) {
            meta <- .read_description(dfile)
            has_depends <- !is.na(meta["Depends"])
            has_imports <- !is.na(meta["Imports"])
            if(has_depends || has_imports) {
                writeLines(c(sprintf("Package: %s",
                                     meta["Package"]),
                             if(has_depends)
                             strwrap(sprintf("Depends: %s",
                                             meta["Depends"]),
                                     indent = 2L,
                                     exdent = 4L),
                             if(has_imports)
                             strwrap(sprintf("Imports: %s",
                                             meta["Imports"]),
                                     indent = 2L,
                                     exdent = 4L)))
            }
        }
    }
}

summarize_check_packages_in_dir_results <-
function(dir, all = TRUE, full = FALSE)
{
    dir <- normalizePath(dir)
    outdirs <- R_check_outdirs(dir, all = all)
    ## Re-arrange to have reverse dependencies last.
    ind <- grepl("^rdepends_", basename(outdirs))
    outdirs <- c(outdirs[!ind], outdirs[ind])
    logs <- file.path(outdirs, "00check.log")
    logs <- logs[file_test("-f", logs)]
    
    results <- check_packages_in_dir_results(logs = logs)

    Map(function(p, r) {
        writeLines(c(sprintf("%s ... %s", p, r$status), r$lines))
    },
        names(results),
        results)

    if(full &&
       !all(as.character(unlist(lapply(results, `[[`, "status"))) ==
            "OK")) {
        writeLines("")
        details <- check_packages_in_dir_details(logs = logs)
        flags <- details$Flags
        out <- cbind(sprintf("Package: %s %s",
                             details$Package, details$Version),
                     ifelse(nzchar(flags),
                            sprintf("Flags: %s\n", flags),
                            ""),
                     sprintf("Check: %s, Result: %s",
                             details$Check, details$Status),
                     c(gsub("\n", "\n  ", details$Output,
                            perl = TRUE, useBytes = TRUE)))
        cat(t(out), sep = c("\n", "", "\n  ", "\n\n"))
    }

    invisible()
}

summarize_check_packages_in_dir_timings <-
function(dir, all = FALSE, full = FALSE)
{
    dir <- normalizePath(dir)
    tfile <- file.path(dir, "timings.tab")
    if(file_test("-f", tfile)) {
        timings <- utils::read.table(tfile)
        ## Should we store the information about reverse dependencies in
        ## some place (rather than rely on the naming convention)?
        if(!all) {
            rdepends <- Sys.glob(file.path(dir, "rdepends_*.Rcheck"))
            timings <- timings[is.na(match(rownames(timings),
                                           sub("rdepends_(.*).Rcheck",
                                               "\\1",
                                               basename(rdepends)))),
                               ]
        }
        print(timings)
    }
    if(full) {
        tfiles <- Sys.glob(file.path(R_check_outdirs(dir, all = all),
                                     "*-Ex.timings"))
        if(length(tfiles)) message("")
        timings <- lapply(tfiles, read.table, header = TRUE)
        ## Order by CPU time.
        timings <- lapply(timings,
                          function(x)
                          x[order(x$user, decreasing = TRUE), ])
        ## This looks silly, but we want a common alignment.
        timings <- split(as.data.frame(lapply(do.call(rbind, timings),
                                              format)),
                         rep.int(sub("\\.Rcheck$", "",
                                     basename(dirname(tfiles))),
                                 sapply(timings, nrow)))
        invisible(Map(function(x, y) {
            writeLines(sprintf("Example timings for package '%s':", x))
            cat(rbind(" ", t(as.matrix(y))),
                sep = c(" ", " ", " ", " ", "\n"))
        },
                      names(timings), timings))
    }
}

read_check_log <-
function(log)
{
    lines <- readLines(log, warn = FALSE)

    ## Drop CRAN check status footer.
    ## Ideally, we would have a more general mechanism to detect footer
    ## information to be skipped (e.g., a line consisting of a single
    ## non-printing control character?)
    pos <- grep("^Current CRAN status:", lines,
                perl = TRUE, useBytes = TRUE)
    if(length(pos) && lines[pos <- (pos[1L] - 1L)] == "") {
        lines <- lines[seq_len(pos - 1L)]
    }

    lines
}


check_packages_in_dir_results <-
function(dir, logs = NULL)
{
    if(is.null(logs))
        logs <- Sys.glob(file.path(dir, "*.Rcheck", "00check.log"))

    results <- lapply(logs, function(log) {
        lines <- read_check_log(log)
        m <- regexpr("^\\*.*\\.\\.\\. *(\\[.*\\])? *(NOTE|WARN|ERROR)", 
                     lines, perl = TRUE, useBytes = TRUE)
        ind <- (m > 0L)
        status <- if(any(ind)) {
            if(all(grepl("NOTE$", regmatches(lines, m), useBytes = TRUE))) {
                "NOTE"
            } else {
                "PROBLEM"
            }
        } else {
            "OK"
        }
        list(status = status, lines = lines[ind])
    })
    names(results) <- sub("\\.Rcheck$", "", basename(dirname(logs)))

    results
}

analyze_check_log <-
function(log, drop_ok = TRUE)
{
    make_results <- function(package, version, flags, chunks)
        list(Package = package, Version = version,
             Flags = flags, Chunks = chunks)

    ## Alternatives for left and right quotes.
    lqa <- "'|\xe2\x80\x98"
    rqa <- "'|\xe2\x80\x99"
    ## Group when used ...

    drop_ok_status_tags <- c("OK", "NONE", "SKIPPED")

    ## Start by reading in.
    lines <- read_check_log(log)

    ## Re-encode to UTF-8 using the session charset info.
    ## All regexp computations will be done using perl = TRUE and
    ## useBytes = TRUE.
    re <- "^\\* using session charset: "
    pos <- grep(re, lines, perl = TRUE, useBytes = TRUE)
    if(length(pos)) {
        enc <- sub(re, "", lines[pos[1L]])
        lines <- iconv(lines, enc, "UTF-8", sub = "byte")
        ## If the check log uses ASCII, there should be no non-ASCII
        ## characters in the message lines: could check for this.
    } else return()

    ## Get header.
    re <- sprintf("^\\* this is package (%s)(.*)(%s) version (%s)(.*)(%s)$",
                  lqa, rqa, lqa, rqa)
    pos <- grep(re, lines, perl = TRUE, useBytes = TRUE)
    if(length(pos)) {
        pos <- pos[1L]
        txt <- lines[pos]
        package <- sub(re, "\\2", txt, perl = TRUE, useBytes = TRUE)
        version <- sub(re, "\\5", txt, perl = TRUE, useBytes = TRUE)
        header <- lines[seq_len(pos - 1L)]
        lines <- lines[-seq_len(pos)]
        ## Get check options from header.
        re <- sprintf("^\\* using options? (%s)(.*)(%s)$", lqa, rqa)
        flags <- if(length(pos <- grep(re, header,
                                       perl = TRUE, useBytes = TRUE))) {
            sub(re, "\\1", header[pos[1L]],
                perl = TRUE, useBytes = TRUE)
        } else ""
    } else return()

    ## Get footer.
    ## Some check systems explicitly record the elapsed time in the
    ## last line:
    len <- length(lines)
    if(grepl("^\\* elapsed time ", lines[len],
             perl = TRUE, useBytes = TRUE)) {
        lines <- lines[-len]
        len <- len - 1L
    }
    num <- length(grep("^(NOTE|WARNING): There",
                       lines[c(len - 1L, len)]))
    if(num > 0L) {
        pos <- seq.int(len - num + 1L, len)
        lines <- lines[-pos]
    }

    analyze_lines <- function(lines) {
        ## We might still have
        ##   * package encoding:
        ## entries for packages declaring a package encoding.
        ## Hopefully all other log entries we still have are
        ##   * checking
        ##   * creating
        ## ones ... apparently, with the exception of
        ##   ** running examples for arch
        ##   ** running tests for arch
        ## So let's drop everything up to the first such entry.
        re <- "^\\*\\*? ((checking|creating|running examples for arch|running tests for arch) .*) \\.\\.\\.( (\\[[^ ]*\\]))? (.*)$"
        ind <- grepl(re, lines, perl = TRUE, useBytes = TRUE)
        csi <- cumsum(ind)
        ind <- (csi > 0)
        chunks <- 
            lapply(split(lines[ind], csi[ind]),
                   function(s) {
                       ## Note that setting
                       ##   _R_CHECK_TEST_TIMING_=yes
                       ##   _R_CHECK_VIGNETTE_TIMING_=yes
                       ## will result in a different chunk format ...
                       line <- s[1L]
                       list(check =
                            sub(re, "\\1", line, perl = TRUE, useBytes = TRUE),
                            status =
                            sub(re, "\\5", line, perl = TRUE, useBytes = TRUE),
                            output = paste(s[-1L], collapse = "\n"))
                   })

        status <- vapply(chunks, `[[`, "", "status")
        if(identical(drop_ok, TRUE) ||
           (is.na(drop_ok) && all(status != "ERROR")))
            chunks <- chunks[is.na(match(status, drop_ok_status_tags))]
        
        chunks
    }

    chunks <- analyze_lines(lines)
    if(!length(chunks) && is.na(drop_ok)) {
        chunks <- list(list(check = "*", status = "OK", output = ""))
    }

    make_results(package, version, flags, chunks)
}

check_packages_in_dir_details <-
function(dir, logs = NULL, drop_ok = TRUE)
{
    ## Build a data frame with columns
    ##   Package Version Check Status Output Flags
    ## and some optimizations (in particular, Check Status Flags can be
    ## factors).

    db_from_logs <- function(logs, drop_ok) {
        out <- lapply(logs, analyze_check_log, drop_ok)
        out <- out[sapply(out, length) > 0L]
        if(!length(out))
            return(matrix(character(), ncol = 6L))
        chunks <- lapply(out, `[[`, "Chunks")
        package <- sapply(out, `[[`, "Package")
        lens <- sapply(chunks, length)
        cbind(rep.int(package, lens),
              rep.int(sapply(out, `[[`, "Version"), lens),
              matrix(as.character(unlist(chunks)), ncol = 3L,
                     byrow = TRUE),
              rep.int(sapply(out, `[[`, "Flags"),
                      lens))
    }

    if(is.null(logs))
        logs <- Sys.glob(file.path(dir, "*.Rcheck", "00check.log"))

    db <- db_from_logs(logs, drop_ok)
    colnames(db) <- c("Package", "Version", "Check", "Status",
                      "Output", "Flags")

    ## Now some cleanups.
    
    ## Alternatives for left and right quotes.
    lqa <- "'|\xe2\x80\x98"
    rqa <- "'|\xe2\x80\x99"
    ## Group when used ...

    mysub <- function(p, r, x) sub(p, r, x, perl = TRUE, useBytes = TRUE)
    
    checks <- db[, "Check"]
    checks <- mysub(sprintf("checking whether package (%s).*(%s) can be installed",
                            lqa, rqa),
                    "checking whether package can be installed", checks)
    checks <- mysub("creating .*-Ex.R",
                    "checking examples creation", checks)
    checks <- mysub("creating .*-manual\\.tex",
                    "checking manual creation", checks)
    checks <- mysub("checking .*-manual\\.tex", "checking manual", checks)
    checks <- mysub(sprintf("checking package vignettes in (%s)inst/doc(%s)",
                            lqa, rqa),
                    "checking package vignettes", checks)
    checks <- mysub("^checking *", "", checks)
    db[, "Check"] <- checks
    ## In fact, for tabulation purposes it would even be more convenient
    ## to shorten the check names ...
    
    db[, "Output"] <- mysub("[[:space:]]+$", "", db[, "Output"])
    
    db <- as.data.frame(db, stringsAsFactors = FALSE)
    db$Check <- as.factor(db$Check)
    db$Status <- as.factor(db$Status)

    db
}
#  File src/library/tools/R/citation.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/

## Tools for computing on CITATION info.

.parse_CITATION_file <-
function(cfile, encoding = NULL)
{
    if(is.null(encoding))
        encoding <- "ASCII"

    ## The parser can only read valid strings, but single-byte locales
    ## can mark their encoding.  The following allows latin1 and UTF-8
    ## citation files to be read in UTF-8 and any single-byte locale
    ## (including C).
    ##
    ## FIXME: if parse() could be told to read strings bytewise,
    ## we could simply convert to UTF-8.
    if(encoding %in% c("latin1", "UTF-8") && !l10n_info()$MBCS) {
        parse(file = cfile, encoding = encoding)
    } else if(encoding %in% c("C", "ASCII")) {
        ## We do want to make sure this is ASCII: in single-byte
        ## locales 8-bit chars are likely to be parsed as bytes.
        ## Based on showNonASCII()
        x <- readLines(cfile, warn = FALSE)
        asc <- iconv(x, "latin1", "ASCII")
        if (any(is.na(asc) | asc != x))
            stop("non-ASCII input in a CITATION file without a declared encoding")
        parse(file = cfile)
    } else {
        con <- file(cfile, encoding = encoding)
        on.exit(close(con))
        parse(con)
    }
}

BibTeX_entry_field_db <-
    list(Article = c("author", "title", "journal", "year"),
         Book = c("author|editor", "title", "publisher", "year"),
         Booklet = c("title"),
         InBook =
         c("author|editor", "title", "chapter", "publisher", "year"),
         InCollection =
         c("author", "title", "booktitle", "publisher", "year"),
         InProceedings = c("author", "title", "booktitle", "year"),
         Manual = c("title"),
         MastersThesis = c("author", "title", "school", "year"),
         Misc = character(),
         PhdThesis = c("author", "title", "school", "year"),
         Proceedings = c("title", "year"),
         TechReport = c("author", "title", "institution", "year"),
         Unpublished = c("author", "title", "note")
         )
## See e.g. lisp/textmodes/bibtex.el in the GNU Emacs sources.

get_CITATION_entry_fields <-
function(file, encoding = "ASCII")
{
    exprs <- .parse_CITATION_file(file, encoding)

    ## Assume that bibentry() or citEntry() only occur at top level.

    ## Try to detect entry type and field names from the calls.
    FOO1 <- FOO2 <- function() match.call(expand.dots = FALSE)
    formals(FOO1) <- formals(utils::citEntry)
    formals(FOO2) <- formals(utils::bibentry)
    ## Could also hard-wire this, of course.
    get_names_of_nonempty_fields <- function(x) {
        names(x)[sapply(x,
                        function(e) {
                            length(e) &&
                            !(is.character(e) &&
                              all(grepl("^[[:space:]]*$", e)))
                        })]
    }

    out <- lapply(exprs,
           function(e) {
               nm <- as.character(e[[1L]])
               if(nm == "citEntry") {
                   e[[1L]] <- as.name("FOO1")
                   e <- as.list(eval(e))
                   entry <- e$entry
                   fields <- get_names_of_nonempty_fields(e$...)
               }
               else if(nm == "bibentry") {
                   e[[1L]] <- as.name("FOO2")
                   e <- as.list(eval(e))
                   entry <- e$bibtype
                   fields <- get_names_of_nonempty_fields(c(e$...,
                                                            as.list(e$other)[-1L]))
               }
               else return()
               entry <- if(!is.character(entry)) NA_character_ else entry[1L]
               list(entry = entry, fields = as.character(fields))
           })

    out <- Filter(Negate(is.null), out)
    ## If we found nothing return nothing ...
    if(!length(out)) return(NULL)
    entries <- sapply(out, `[[`, 1L)
    fields <- lapply(out, `[[`, 2L)
    out <- data.frame(File = file,
                      Entry = entries,
                      stringsAsFactors = FALSE)
    out$Fields <- fields
    out
}


find_missing_required_BibTeX_fields <-
function(entry, fields)
{
    pos <- match(tolower(entry),
                 tolower(names(BibTeX_entry_field_db)))
    if(is.na(pos)) {
        ## Invalid entry.
        return(NA_character_)
    }
    rfields <- BibTeX_entry_field_db[[pos]]
    if(!length(rfields)) return(character())
    ## Go for legibility/generality rather than efficiency.
    fields <- tolower(fields)
    ok <- sapply(strsplit(rfields, "|", fixed = TRUE),
                 function(f) any(f %in% fields))
    rfields[!ok]
}
#  File src/library/tools/R/dynamicHelp.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/


## This may be asked for
##  R.css, favicon.ico
##  searches with path = "/doc/html/Search"
##  documentation with path = "/doc/....", possibly updated under tempdir()/.R
##  demos with path "/demo/*"
##  Running demos, using path "/Demo/*"
##  html help, either by topic, /library/<pkg>/help/<topic> (pkg=NULL means any)
##             or by file, /library/<pkg>/html/<file>.html
httpd <- function(path, query, ...)
{
    .HTMLdirListing <- function(dir, base, up)
    {
        files <- list.files(dir)    # note, no hidden files are listed
        out <- HTMLheader(paste0("Listing of directory<br>", dir),
        		  headerTitle = paste("R:", dir), logo=FALSE,
        		  up = up)
        if(!length(files))
            out <- c(out, gettext("No files in this directory"))
        else {
            urls <- paste0('<a href="', base, '/', files, '">', files, '</a>')
            out <- c(out, "<dl>",
                     paste0("<dd>", mono(iconv(urls, "", "UTF-8")), "</dd>"),
                     "</dl>")
        }
        out <- c(out, "<hr>\n</body></html>")
        list(payload = paste(out, collapse="\n"))
    }

    .HTMLusermanuals <- function()
    {
        pkgs <- unlist(.get_standard_package_names())

        out <- HTMLheader("R User Manuals")
        for (pkg in pkgs) {
            vinfo <- getVignetteInfo(pkg)
     	    if (nrow(vinfo)) 
         	out <- c(out, paste0('<h2>Manuals in package', sQuote(pkg),'</h2>'),
         		 makeVignetteTable(cbind(Package=pkg, vinfo[,c("File", "Title", "PDF", "R")])))
     	}
        out <- c(out, "<hr>\n</body></html>")
        list(payload = paste(out, collapse="\n"))
    }

    .HTMLsearch <- function(query)
    {
    	bool <- function(x) as.logical(as.numeric(x))
        res <- if(identical(names(query), "category"))
            help.search(keyword = query, verbose = 1L, use_UTF8 = TRUE)
        else {
            fields = c("alias", "concept", "title")
            args <- list(pattern = ".")
            for (i in seq_along(query))
            	switch(names(query)[i],
            		pattern = args$pattern <- query[i],
            		title = if (!bool(query[i])) fields <- setdiff(fields, "title"),
            		keyword = if (bool(query[i])) fields <- union(fields, "keyword"),
            		alias = if (!bool(query[i])) fields <- setdiff(fields, "alias"),
            		concept = if (!bool(query[i])) fields <- setdiff(fields, "concept"),
            		name = if (bool(query[i])) fields <- union(fields, "name"),
            		agrep = {
            		    args$agrep <- as.logical(query[i])
            		    if (is.na(args$agrep))
            		    	args$agrep <- as.numeric(query[i])
            		    if (is.na(args$agrep))
            		     	args$agrep <- query[i]
            		},
            		ignore.case = args$ignore.case <- bool(query[i]),
            		types = args$types <- strsplit(query[i], ";")[[1L]],
            		package = args$package <- strsplit(query[i], ";")[[1L]],
            		lib.loc = args$lib.loc <- strsplit(query[i], ";")[[1L]],
            		warning("Unrecognized search field: ", names(query)[i],
                                domain = NA)
                       )
            args$fields <- fields
            args$use_UTF8 <- TRUE
            do.call(help.search, args)
        }
        types <- res$types
        res <- res$matches
        title <- "Search Results"
        out <- c(HTMLheader(title),
                 if ("pattern" %in% names(query))
                     paste0('The search string was <b>"', query["pattern"], '"</b>'),
                 '<hr>\n')

        if(!NROW(res))
            out <- c(out, gettext("No results found"))
        else {
            vigfile0 <- ""
            vigDB <- NULL
            for (type in types) {
		if(NROW(temp <- res[res[,"Type"] == type,,drop=FALSE]) > 0)
		    switch(type,
		    vignette = {
			out <- c(out, paste0("<h3>", gettext("Vignettes:"), "</h3>"), "<dl>")
			n <- NROW(temp)
			vignettes <- matrix("", n, 5)
			colnames(vignettes) <- c("Package", "File",
			                         "Title", "PDF","R")
			for (i in seq_len(NROW(temp))) {
			    topic <- temp[i, "topic"]
			    pkg <- temp[i, "Package"]
			    vigfile <- file.path(temp[i, "LibPath"], "Meta", "vignette.rds")
			    if (!identical(vigfile, vigfile0)) {
			    	vigDB <- readRDS(vigfile)
			    	vigfile0 <- vigfile
			    }
			    vignette <- vigDB[topic == file_path_sans_ext(vigDB$PDF),]
			    # There should be exactly one row in the result, but
			    # bad packages might have more, e.g. vig.Snw and vig.Rnw
			    vignettes[i,] <- c(pkg, unlist(vignette[1,c("File", "Title", "PDF", "R")]))
			 }
			 out <- c(out, makeVignetteTable(vignettes))
		    },
		    demo = {
			out <- c(out, paste0("<h3>", gettext("Code demonstrations:"), "</h3>"))
			out <- c(out, makeDemoTable(temp))
		    },
		    help = {
			out <- c(out, paste0("<h3>", gettext("Help pages:"), "</h3>"))
			out <- c(out, makeHelpTable(temp))
		    })
	    }
        }
        out <- c(out, "<hr>\n</body></html>")
        list(payload = paste(out, collapse="\n"))
    }

    unfix <- function(file)
    {
        ## we need to re-fix links altered by fixup.package.URLs
        ## in R < 2.10.0
        fixedfile <- sub("/html/.*", "/fixedHTMLlinks", file)
        if(file.exists(fixedfile)) {
            top <- readLines(fixedfile)
            lines <- readLines(file)
            lines <- gsub(paste(top, "library", sep="/"),
                          "../../", lines, fixed = TRUE)
            lines <- gsub(paste(top, "doc/", sep = "/"),
                          "../../../doc/", lines, fixed = TRUE)
            return(list(payload=paste(lines, collapse="\n")))
        }
        list(file = file)
    }

    mime_type <- function(path)
    {
        ext <- strsplit(path, ".", fixed = TRUE)[[1L]]
        if(n <- length(ext)) ext <- ext[n] else ""
        switch(ext,
               "css" = "text/css",
               "gif" = "image/gif", # in R2HTML
               "jpg" = "image/jpeg",
               "png" = "image/png",
               "svg" = "image/svg+xml",
               "html" = "text/html",
               "pdf" = "application/pdf",
               "eps" =,
               "ps" = "application/postscript", # in GLMMGibbs, mclust
               "sgml" = "text/sgml", # in RGtk2
               "xml" = "text/xml",  # in RCurl
               "text/plain")
    }

    sQuote <- function(text)
        paste0("&lsquo;", text, "&rsquo;")
    mono <- function(text)
        paste0('<span class="samp">', text, "</span>")

    error_page <- function(msg)
        list(payload =
             paste0(HTMLheader("httpd error"), msg, "\n</body></html>"))

    cssRegexp <- "^/library/([^/]*)/html/R.css$"
    if (grepl("R\\.css$", path) && !grepl(cssRegexp, path))
        return(list(file = file.path(R.home("doc"), "html", "R.css"),
                    "content-type" = "text/css"))
    else if(path == "/favicon.ico")
        return(list(file = file.path(R.home("doc"), "html", "favicon.ico")))
    else if(path == "/NEWS")
         return(list(file = file.path(R.home("doc"), "html", "NEWS.html")))
    else if(grepl("^/NEWS[.][[:digit:]]$", path)) 
    	return(list(file = file.path(R.home(), sub("/", "", path)),
    	            "content-type" = "text/plain"))
    else if(!grepl("^/(doc|library|session)/", path))
        return(error_page(paste("Only NEWS and URLs under", mono("/doc"),
                                "and", mono("/library"), "are allowed")))
    else if(path == "/doc/html/UserManuals.html")
    	return(.HTMLusermanuals())

    ## ----------------------- per-package documentation ---------------------
    ## seems we got ../..//<pkg> in the past
    fileRegexp <- "^/library/+([^/]*)/html/([^/]*)\\.html$"
    topicRegexp <- "^/library/+([^/]*)/help/([^/]*)$"
    docRegexp <- "^/library/([^/]*)/doc(.*)"
    demoRegexp <- "^/library/([^/]*)/demo$"
    demosRegexp <- "^/library/([^/]*)/demo/([^/]*)$"
    DemoRegexp <- "^/library/([^/]*)/Demo/([^/]*)$"
    newsRegexp <- "^/library/([^/]*)/NEWS$"
    figureRegexp <- "^/library/([^/]*)/(help|html)/figures/([^/]*)$"
    sessionRegexp <- "^/session/"

    file <- NULL
    if (grepl(topicRegexp, path)) {
        ## ----------------------- package help by topic ---------------------
    	pkg <- sub(topicRegexp, "\\1", path)
    	if (pkg == "NULL") pkg <- NULL  # There were multiple hits in the console
    	topic <- sub(topicRegexp, "\\2", path)
        ## if a package is specified, look there first, then everywhere
    	if (!is.null(pkg)) # () avoids deparse here
    	    file <- help(topic, package = (pkg), help_type = "text")
    	if (!length(file))
            file <- help(topic, help_type = "text", try.all.packages = TRUE)
	if (!length(file)) {
            msg <- gettextf("No help found for topic %s in any package.",
                            mono(topic))
	    return(list(payload = error_page(msg)))
	} else if (length(file) == 1L) {
	    path <- dirname(dirname(file))
	    file <- paste0('../../', basename(path), '/html/',
                           basename(file), '.html')
            ## cat("redirect to", file, "\n")
            ## We need to do this because there are static HTML pages
            ## with links to "<file>.html" for topics in the same
            ## package, and if we served one of such a page as a link from
            ## a different package those links on the page would not work.
	    return(list(payload = paste0('Redirect to <a href="', file, '">"',
                                         basename(file), '"</a>'),
	    		"content-type" = 'text/html',
	    		header = paste0('Location: ', file),
	    		"status code" = 302L)) # temporary redirect
	} else if (length(file) > 1L) {
            paths <- dirname(dirname(file))
            fp <- file.path(paths, "Meta", "Rd.rds")
            tp <- basename(file)
            titles <- tp
            for (i in seq_along(fp)) {
                tmp <- try(readRDS(fp[i]))
                titles[i] <- if(inherits(tmp, "try-error"))
                    "unknown title" else
                    tmp[file_path_sans_ext(tmp$File) == tp[i], "Title"]
            }
            packages <- paste('<dt><a href="../../', basename(paths), '/html/',
                              basename(file), '.html">', titles,
                              '</a></dt><dd> (in package <a href="../../',
                              basename(paths),
                              '/html/00Index.html">', basename(paths),
                              '</a> in library ', dirname(paths), ")</dd>",
                              sep = "", collapse = "\n")

            return(list(payload =
                        paste("<p>",
                              ## for languages with multiple plurals ....
                              sprintf(ngettext(length(paths),
                                               "Help on topic '%s' was found in the following package:",
                                               "Help on topic '%s' was found in the following packages:"
                                               ), topic),
                              "</p><dl>\n",
                              packages, "</dl>", sep = "", collapse = "\n")
                        ))
        }
    } else if (grepl(fileRegexp, path)) {
        ## ----------------------- package help by file ---------------------
    	pkg <- sub(fileRegexp, "\\1", path)
    	h0 <- helpdoc <- sub(fileRegexp, "\\2", path)
        if (helpdoc == "00Index") {
            ## ------------------- package listing ---------------------
            file <- system.file("html", "00Index.html", package = pkg)
            if(!nzchar(file) || !file.exists(file)) {
                msg <- if(nzchar(system.file(package = pkg)))
                    gettextf("No package index found for package %s",
                             mono(pkg))
                else
                    gettextf("No package named %s could be found",
                             mono(pkg))
                return(error_page(msg))
            } else {
                if(.Platform$OS.type == "windows") return(unfix(file))
                return(list(file = file))
            }
    	}
        ## ----------------------- package help file ---------------------
        path <- system.file("help", package = pkg)
        if (!nzchar(path)) {
            msg <- if(nzchar(system.file(package = pkg)))
                gettextf("No help found for package %s", mono(pkg) )
            else
                gettextf("No package named %s could be found", mono(pkg))
            return(error_page(msg))
        }
        ## if 'topic' is not a help doc, try it as an alias in the package
        contents <- readRDS(sub("/help", "/Meta/Rd.rds", path, fixed = TRUE))
        files <- sub("\\.[Rr]d$", "", contents$File)
        if(! helpdoc %in% files) {
            ## or call help()
            aliases <- contents$Aliases
            lens <- sapply(aliases, length)
            aliases <- structure(rep.int(contents$File, lens),
                                 names = unlist(aliases))
            tmp <- sub("\\.[Rr]d$", "", aliases[helpdoc])
            if(is.na(tmp)) {
                msg <- gettextf("Link %s in package %s could not be located",
                                mono(helpdoc), mono(pkg))
                files <- help(helpdoc, help_type = "text",
                              try.all.packages = TRUE)
                if (length(files)) {
                    path <- dirname(dirname(files))
                    files <- paste0('/library/', basename(path), '/html/',
                                    basename(files), '.html')
                    msg <- c(msg, "<br>",
                             "However, you might be looking for one of",
                             "<p></p>",
                             paste0('<p><a href="', files, '">',
                                    mono(files), "</a></p>")
                             )
                }
                return(error_page(paste(msg, collapse = "\n")))
            }
            helpdoc <- tmp
        }

        ## Now we know which document we want in which package
	dirpath <- dirname(path)
	pkgname <- basename(dirpath)
	RdDB <- file.path(path, pkgname)
        outfile <- tempfile("Rhttpd")
        Rd2HTML(utils:::.getHelpFile(file.path(path, helpdoc)),
                out = outfile, package = dirpath,
                dynamic = TRUE)
        on.exit(unlink(outfile))
        return(list(payload = paste(readLines(outfile), collapse = "\n")))
    } else if (grepl(docRegexp, path)) {
        ## ----------------------- package doc directory ---------------------
    	pkg <- sub(docRegexp, "\\1", path)
    	rest <- sub(docRegexp, "\\2", path)
        docdir <- system.file("doc", package = pkg)
        up <- paste0("/library/", pkg, "/html/00Index.html")
        if(!nzchar(docdir))
            return(error_page(gettextf("No docs found for package %s",
                                       mono(pkg))))
        if(nzchar(rest) && rest != "/") {
            ## FIXME should we check existence here?
            file <- paste0(docdir, rest)
            if(isTRUE(file.info(file)$isdir))
                return(.HTMLdirListing(file,
                                       paste0("/library/", pkg, "/doc", rest),
                                       up))
            else
                return(list(file = file, "content-type" = mime_type(rest)))
        } else {
            ## request to list <pkg>/doc
            return(.HTMLdirListing(docdir,
                                   paste("/library", pkg, "doc", sep="/"),
                                   up))
        }
    } else if (grepl(demoRegexp, path)) {
    	pkg <- sub(demoRegexp, "\\1", path)

    	url <- paste0("http://127.0.0.1:", httpdPort,
                      "/doc/html/Search?package=",
                      pkg, "&agrep=FALSE&types=demo")
    	return(list(payload = paste0('Redirect to <a href="', url,
    				'">help.search()</a>'),
		    		"content-type" = 'text/html',
		    		header = paste0('Location: ', url),
	    		"status code" = 302L)) # temporary redirect
    } else if (grepl(demosRegexp, path)) {
	    pkg <- sub(demosRegexp, "\\1", path)
	    demo <- sub(demosRegexp, "\\2", path)
	    file <- system.file(file.path("demo", demo), package=pkg)
	    return(list(file = file, "content-type" = mime_type(demo)))

    } else if (grepl(DemoRegexp, path)) {
    	pkg <- sub(DemoRegexp, "\\1", path)
    	demo <- sub(DemoRegexp, "\\2", path)
    	demo(demo, package=pkg, character.only=TRUE, ask=FALSE)
	return( list(payload = paste0("Demo '", pkg, "::", demo,
				"' was run in the console.",
				" To repeat, type 'demo(",
				pkg, "::", demo,
				")' in the console.")) )
    } else if (grepl(newsRegexp, path)) {
    	pkg <- sub(newsRegexp, "\\1", path)
    	formatted <- toHTML(news(package = pkg),
    		            title=paste("NEWS in package", sQuote(pkg)),
    			    up="html/00Index.html")
        if (length(formatted))
    	    return( list(payload = paste(formatted, collapse="\n")) )
    	else
    	    return( list(file = system.file("NEWS", package = pkg),
    	                 "content-type" = "text/plain") )
    } else if (grepl(figureRegexp, path)) {
        pkg <- sub(figureRegexp, "\\1", path)
        fig <- sub(figureRegexp, "\\3", path)
        file <- system.file("help", "figures", fig, package=pkg)
        return( list(file=file, "content-type" = mime_type(fig)) )
    } else if (grepl(sessionRegexp, path)) {
        tail <- sub(sessionRegexp, "", path)
    	file <- file.path(tempdir(), tail)
    	return( list(file=file, "content-type" = mime_type(tail)) )
    } else if (grepl(cssRegexp, path)) {
    	pkg <- sub(cssRegexp, "\\1", path)
        return( list(file = system.file("html", "R.css", package = pkg),
                     "content-type" = "text/css") )
    } else if (grepl("^/library/", path)) {
        descRegexp <- "^/library/+([^/]+)/+DESCRIPTION$"
        if(grepl(descRegexp, path)) {
            pkg <- sub(descRegexp, "\\1", path)
            file <- system.file("DESCRIPTION", package = pkg)
            return(list(file = file, "content-type" = "text/plain"))
        } else
            return(error_page(gettextf("Only help files, %s, %s and files under %s and %s in a package can be viewed", mono("NEWS"),
                              mono("DESCRIPTION"), mono("doc/"), mono("demo/"))))
    }

    ## ----------------------- R docs ---------------------
    if(path == "/doc/html/Search.html") {
        ## redirect to the page that has search enabled
        list(file = file.path(R.home("doc"), "html/SearchOn.html"))
    } else if(path == "/doc/html/Search") {
        .HTMLsearch(query)
    } else if(path == "/doc/html/packages.html") {
        ## remake as needed
        utils::make.packages.html(temp = TRUE)
        list(file = file.path(tempdir(), ".R", path))
    } else if(grepl("doc/html/.*html$" , path) &&
              file.exists(tmp <- file.path(tempdir(), ".R", path))) {
        ## use updated version, e.g. of packages.html
        list(file = tmp)
    } else {
        if(grepl("^/doc/", path)) {
            ## /doc/AUTHORS and so on.
            file <- file.path(R.home("doc"), sub("^/doc", "", path))
        } else return(error_page(gettextf("unsupported URL %s", mono(path))))
        if(!file.exists(file))
            error_page(gettextf("URL %s was not found", mono(path)))
        else
            list(file = file, "content-type" = mime_type(path))
    }
}

## 0 = untried, < 0 = failed to start,  > 0 = actual port
httpdPort <- 0L

startDynamicHelp <- function(start=TRUE)
{
    env <- environment(startDynamicHelp)
    if(nzchar(Sys.getenv("R_DISABLE_HTTPD"))) {
        unlockBinding("httpdPort", env)
        httpdPort <<- -1L
        lockBinding("httpdPort", env)
        warning("httpd server disabled by R_DISABLE_HTTPD", immediate. = TRUE)
        utils::flush.console()
        return(httpdPort)
    }
    if (start && httpdPort) {
        if(httpdPort > 0) stop("server already running")
        else stop("server could not be started on an earlier attempt")
    }
    if(!start && httpdPort <= 0L)
        stop("no running server to stop")
    unlockBinding("httpdPort", env)
    if (start) {
        message("starting httpd help server ...", appendLF = FALSE)
        utils::flush.console()
        OK <- FALSE
        ports <- getOption("help.ports")
        if (is.null(ports)) {
	    ## Choose 10 random port numbers between 10000 and 32000.
	    ## The random seed might match
	    ## on multiple instances, so add the time as well.  But the
	    ## time may only be accurate to seconds, so rescale it to
	    ## 5 minute units.
            ports <- 10000 + 22000*((stats::runif(10) + unclass(Sys.time())/300) %% 1)
        }
        ports <- as.integer(ports)
        for(i in seq_along(ports)) {
            ## the next can throw an R-level error,
            ## so do not assign port unless it succeeds.
	    status <- .Call(startHTTPD, "127.0.0.1", ports[i])
	    if (status == 0L) {
                OK <- TRUE
                httpdPort <<- ports[i]
                break
            }
            if (status != -2L) break
            ## so status was -2, which means port in use
	}
        if (OK) {
            message(" done")
            utils::flush.console()
            ## FIXME: actually test the server
        } else {
            warning("failed to start the httpd server", immediate. = TRUE)
            utils::flush.console()
            httpdPort <<- -1L
        }
    } else {
        ## Not really tested
        .Call(stopHTTPD)
    	httpdPort <<- 0L
    }
    lockBinding("httpdPort", env)
    invisible(httpdPort)
}

## environment holding potential custom httpd handlers
.httpd.handlers.env <- new.env()
#  File src/library/tools/R/encodings.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2012 The R 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 of the License, 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/

get_IANA_character_sets <-
function(file = NULL)
{
    ## Master URI is
    ##   http://www.iana.org/assignments/character-sets
    if(is.null(file))
        file <- file.path(R.home("share"), "encodings",
                          "character-sets")
    lines <- readLines(file)
    ## Start with first Name: entry, and end with REFERENCES.
    spos <- min(grep("^Name:", lines))
    epos <- min(grep("^REFERENCES", lines)) - 1
    lines <- lines[spos : epos]
    ## Omit 'Alias: None' and similar lines.
    if(any(ind <- grep("^[[:alnum:]]+:[[:space:]]+None[[:space:]]*$",
                       lines)))
        lines <- lines[-ind]
    ## And be nice (version last updated 2007-05-14 was invalid DCF).
    if(any(ind <- grep("^[^[:blank:]][^:]*$", lines)))
        lines <- lines[-ind]
    entries <- paste(lines, collapse = "\n")
    ## What we now have is in DCF format, with multiple fields.
    con <- textConnection(entries)
    on.exit(close(con))
    out <- read.dcf(con,
                    fields = c("Name", "MIBenum", "Source", "Alias"),
                    all = TRUE)
    ## Prefer 'Aliases' for historical reasons.
    names(out)[names(out) == "Alias"] <- "Aliases"
    ## Preferred MIME names.
    MIME <- sapply(mapply("c", out$Name, out$Aliases),
                   function(u) {
                       if(any(ind <- grep("preferred MIME name", u)))
                           sapply(strsplit(u[ind], " +"), "[[", 1L)
                       else
                           character()
                   })
    out$MIME <- MIME
    out$Name <- sub(" +.*", "", out$Name)
    out$Aliases <- lapply(out$Aliases, function(s) sub(" +.*", "", s))
    out$MIBenum <- as.integer(out$MIBenum)

    out
}

charset_to_Unicode <- local({
    ISOLatin1 <- c(0:127, rep.int(0, 32), 160:255)
    ISOLatin2 <- c(0:127, rep.int(0, 32),
  0x00a0, 0x0104, 0x02d8, 0x0141, 0x00a4, 0x013d, 0x015a, 0x00a7,
  0x00a8, 0x0160, 0x015e, 0x0164, 0x0179, 0x00ad, 0x017d, 0x017b,
  0x00b0, 0x0105, 0x02db, 0x0142, 0x00b4, 0x013e, 0x015b, 0x02c7,
  0x00b8, 0x0161, 0x015f, 0x0165, 0x017a, 0x02dd, 0x017e, 0x017c,
  0x0154, 0x00c1, 0x00c2, 0x0102, 0x00c4, 0x0139, 0x0106, 0x00c7,
  0x010c, 0x00c9, 0x0118, 0x00cb, 0x011a, 0x00cd, 0x00ce, 0x010e,
  0x0110, 0x0143, 0x0147, 0x00d3, 0x00d4, 0x0150, 0x00d6, 0x00d7,
  0x0158, 0x016e, 0x00da, 0x0170, 0x00dc, 0x00dd, 0x0162, 0x00df,
  0x0155, 0x00e1, 0x00e2, 0x0103, 0x00e4, 0x013a, 0x0107, 0x00e7,
  0x010d, 0x00e9, 0x0119, 0x00eb, 0x011b, 0x00ed, 0x00ee, 0x010f,
  0x0111, 0x0144, 0x0148, 0x00f3, 0x00f4, 0x0151, 0x00f6, 0x00f7,
  0x0159, 0x016f, 0x00fa, 0x0171, 0x00fc, 0x00fd, 0x0163, 0x02d9)
    ISOLatin7 <- c(0:127, rep.int(0, 32),
  0x00a0, 0x201d, 0x00a2, 0x00a3, 0x00a4, 0x201e, 0x00a6, 0x00a7,
  0x00d8, 0x00a9, 0x0156, 0x00ab, 0x00ac, 0x00ad, 0x00ae, 0x00c6,
  0x00b0, 0x00b1, 0x00b2, 0x00b3, 0x201c, 0x00b5, 0x00b6, 0x00b7,
  0x00f8, 0x00b9, 0x0157, 0x00bb, 0x00bc, 0x00bd, 0x00be, 0x00e6,
  0x0104, 0x012e, 0x0100, 0x0106, 0x00c4, 0x00c5, 0x0118, 0x0112,
  0x010c, 0x00c9, 0x0179, 0x0116, 0x0122, 0x0136, 0x012a, 0x013b,
  0x0160, 0x0143, 0x0145, 0x00d3, 0x014c, 0x00d5, 0x00d6, 0x00d7,
  0x0172, 0x0141, 0x015a, 0x016a, 0x00dc, 0x017b, 0x017d, 0x00df,
  0x0105, 0x012f, 0x0101, 0x0107, 0x00e4, 0x00e5, 0x0119, 0x0113,
  0x010d, 0x00e9, 0x017a, 0x0117, 0x0123, 0x0137, 0x012b, 0x013c,
  0x0161, 0x0144, 0x0146, 0x00f3, 0x014d, 0x00f5, 0x00f6, 0x00f7,
  0x0173, 0x0142, 0x015b, 0x016b, 0x00fc, 0x017c, 0x017e, 0x2019)
    ISOLatin9 <- c(0:127, rep.int(0, 32),
  0x00a0, 0x00a1, 0x00a2, 0x00a3, 0x20ac, 0x00a5, 0x0160, 0x00a7,
  0x0161, 0x00a9, 0x00aa, 0x00ab, 0x00ac, 0x00ad, 0x00ae, 0x00af,
  0x00b0, 0x00b1, 0x00b2, 0x00b3, 0x017d, 0x00b5, 0x00b6, 0x00b7,
  0x017e, 0x00b9, 0x00ba, 0x00bb, 0x0152, 0x0153, 0x0178, 0x00bf,
                   192:255)
    Cyrillic <- c(0:127, rep.int(0, 32),
  0x00a0, 0x0401, 0x0402, 0x0403, 0x0404, 0x0405, 0x0406, 0x0407,
  0x0408, 0x0409, 0x040a, 0x040b, 0x040c, 0x00ad, 0x040e, 0x040f,
  0x0410, 0x0411, 0x0412, 0x0413, 0x0414, 0x0415, 0x0416, 0x0417,
  0x0418, 0x0419, 0x041a, 0x041b, 0x041c, 0x041d, 0x041e, 0x041f,
  0x0420, 0x0421, 0x0422, 0x0423, 0x0424, 0x0425, 0x0426, 0x0427,
  0x0428, 0x0429, 0x042a, 0x042b, 0x042c, 0x042d, 0x042e, 0x042f,
  0x0430, 0x0431, 0x0432, 0x0433, 0x0434, 0x0435, 0x0436, 0x0437,
  0x0438, 0x0439, 0x043a, 0x043b, 0x043c, 0x043d, 0x043e, 0x043f,
  0x0440, 0x0441, 0x0442, 0x0443, 0x0444, 0x0445, 0x0446, 0x0447,
  0x0448, 0x0449, 0x044a, 0x044b, 0x044c, 0x044d, 0x044e, 0x044f,
  0x2116, 0x0451, 0x0452, 0x0453, 0x0454, 0x0455, 0x0456, 0x0457,
  0x0458, 0x0459, 0x045a, 0x045b, 0x045c, 0x00a7, 0x045e, 0x045f)
    Greek <- c(0:127, rep.int(0, 32),
  0x00a0, 0x2018, 0x2019, 0x00a3, 0x20ac, 0x20af, 0x00a6, 0x00a7,
  0x00a8, 0x00a9, 0x037a, 0x00ab, 0x00ac, 0x00ad, 0xfffd, 0x2015,
  0x00b0, 0x00b1, 0x00b2, 0x00b3, 0x0384, 0x0385, 0x0386, 0x00b7,
  0x0388, 0x0389, 0x038a, 0x00bb, 0x038c, 0x00bd, 0x038e, 0x038f,
  0x0390, 0x0391, 0x0392, 0x0393, 0x0394, 0x0395, 0x0396, 0x0397,
  0x0398, 0x0399, 0x039a, 0x039b, 0x039c, 0x039d, 0x039e, 0x039f,
  0x03a0, 0x03a1, 0xfffd, 0x03a3, 0x03a4, 0x03a5, 0x03a6, 0x03a7,
  0x03a8, 0x03a9, 0x03aa, 0x03ab, 0x03ac, 0x03ad, 0x03ae, 0x03af,
  0x03b0, 0x03b1, 0x03b2, 0x03b3, 0x03b4, 0x03b5, 0x03b6, 0x03b7,
  0x03b8, 0x03b9, 0x03ba, 0x03bb, 0x03bc, 0x03bd, 0x03be, 0x03bf,
  0x03c0, 0x03c1, 0x03c2, 0x03c3, 0x03c4, 0x03c5, 0x03c6, 0x03c7,
  0x03c8, 0x03c9, 0x03ca, 0x03cb, 0x03cc, 0x03cd, 0x03ce, 0xfffd)
    KOI8R <- c(0:127,
  0x2500, 0x2502, 0x250c, 0x2510, 0x2514, 0x2518, 0x251c, 0x2524,
  0x252c, 0x2534, 0x253c, 0x2580, 0x2584, 0x2588, 0x258c, 0x2590,
  0x2591, 0x2592, 0x2593, 0x2320, 0x25a0, 0x2219, 0x221a, 0x2248,
  0x2264, 0x2265, 0x00a0, 0x2321, 0x00b0, 0x00b2, 0x00b7, 0x00f7,
  0x2550, 0x2551, 0x2552, 0x0451, 0x2553, 0x2554, 0x2555, 0x2556,
  0x2557, 0x2558, 0x2559, 0x255a, 0x255b, 0x255c, 0x255d, 0x255e,
  0x255f, 0x2560, 0x2561, 0x0401, 0x2562, 0x2563, 0x2564, 0x2565,
  0x2566, 0x2567, 0x2568, 0x2569, 0x256a, 0x256b, 0x256c, 0x00a9,
  0x044e, 0x0430, 0x0431, 0x0446, 0x0434, 0x0435, 0x0444, 0x0433,
  0x0445, 0x0438, 0x0439, 0x043a, 0x043b, 0x043c, 0x043d, 0x043e,
  0x043f, 0x044f, 0x0440, 0x0441, 0x0442, 0x0443, 0x0436, 0x0432,
  0x044c, 0x044b, 0x0437, 0x0448, 0x044d, 0x0449, 0x0447, 0x044a,
  0x042e, 0x0410, 0x0411, 0x0426, 0x0414, 0x0415, 0x0424, 0x0413,
  0x0425, 0x0418, 0x0419, 0x041a, 0x041b, 0x041c, 0x041d, 0x041e,
  0x041f, 0x042f, 0x0420, 0x0421, 0x0422, 0x0423, 0x0416, 0x0412,
  0x042c, 0x042b, 0x0417, 0x0428, 0x042d, 0x0429, 0x0427, 0x042a)
    KOI8U <- c(0:127,
  0x2500, 0x2502, 0x250c, 0x2510, 0x2514, 0x2518, 0x251c, 0x2524,
  0x252c, 0x2534, 0x253c, 0x2580, 0x2584, 0x2588, 0x258c, 0x2590,
  0x2591, 0x2592, 0x2593, 0x2320, 0x25a0, 0x2219, 0x221a, 0x2248,
  0x2264, 0x2265, 0x00a0, 0x2321, 0x00b0, 0x00b2, 0x00b7, 0x00f7,
  0x2550, 0x2551, 0x2552, 0x0451, 0x0454, 0x2554, 0x0456, 0x0457,
  0x2557, 0x2558, 0x2559, 0x255a, 0x255b, 0x0491, 0x255d, 0x255e,
  0x255f, 0x2560, 0x2561, 0x0401, 0x0404, 0x2563, 0x0406, 0x0407,
  0x2566, 0x2567, 0x2568, 0x2569, 0x256a, 0x0490, 0x256c, 0x00a9,
  0x044e, 0x0430, 0x0431, 0x0446, 0x0434, 0x0435, 0x0444, 0x0433,
  0x0445, 0x0438, 0x0439, 0x043a, 0x043b, 0x043c, 0x043d, 0x043e,
  0x043f, 0x044f, 0x0440, 0x0441, 0x0442, 0x0443, 0x0436, 0x0432,
  0x044c, 0x044b, 0x0437, 0x0448, 0x044d, 0x0449, 0x0447, 0x044a,
  0x042e, 0x0410, 0x0411, 0x0426, 0x0414, 0x0415, 0x0424, 0x0413,
  0x0425, 0x0418, 0x0419, 0x041a, 0x041b, 0x041c, 0x041d, 0x041e,
  0x041f, 0x042f, 0x0420, 0x0421, 0x0422, 0x0423, 0x0416, 0x0412,
  0x042c, 0x042b, 0x0417, 0x0428, 0x042d, 0x0429, 0x0427, 0x042a)
    CP1250 <- c(0:127,
  0x20ac, 0xfffd, 0x201a, 0xfffd, 0x201e, 0x2026, 0x2020, 0x2021,
  0xfffd, 0x2030, 0x0160, 0x2039, 0x015a, 0x0164, 0x017d, 0x0179,
  0xfffd, 0x2018, 0x2019, 0x201c, 0x201d, 0x2022, 0x2013, 0x2014,
  0xfffd, 0x2122, 0x0161, 0x203a, 0x015b, 0x0165, 0x017e, 0x017a,
  0x00a0, 0x02c7, 0x02d8, 0x0141, 0x00a4, 0x0104, 0x00a6, 0x00a7,
  0x00a8, 0x00a9, 0x015e, 0x00ab, 0x00ac, 0x00ad, 0x00ae, 0x017b,
  0x00b0, 0x00b1, 0x02db, 0x0142, 0x00b4, 0x00b5, 0x00b6, 0x00b7,
  0x00b8, 0x0105, 0x015f, 0x00bb, 0x013d, 0x02dd, 0x013e, 0x017c,
  0x0154, 0x00c1, 0x00c2, 0x0102, 0x00c4, 0x0139, 0x0106, 0x00c7,
  0x010c, 0x00c9, 0x0118, 0x00cb, 0x011a, 0x00cd, 0x00ce, 0x010e,
  0x0110, 0x0143, 0x0147, 0x00d3, 0x00d4, 0x0150, 0x00d6, 0x00d7,
  0x0158, 0x016e, 0x00da, 0x0170, 0x00dc, 0x00dd, 0x0162, 0x00df,
  0x0155, 0x00e1, 0x00e2, 0x0103, 0x00e4, 0x013a, 0x0107, 0x00e7,
  0x010d, 0x00e9, 0x0119, 0x00eb, 0x011b, 0x00ed, 0x00ee, 0x010f,
  0x0111, 0x0144, 0x0148, 0x00f3, 0x00f4, 0x0151, 0x00f6, 0x00f7,
  0x0159, 0x016f, 0x00fa, 0x0171, 0x00fc, 0x00fd, 0x0163, 0x02d9)
    CP1251 <- c(0:127,
  0x0402, 0x0403, 0x201a, 0x0453, 0x201e, 0x2026, 0x2020, 0x2021,
  0x20ac, 0x2030, 0x0409, 0x2039, 0x040a, 0x040c, 0x040b, 0x040f,
  0x0452, 0x2018, 0x2019, 0x201c, 0x201d, 0x2022, 0x2013, 0x2014,
  0xfffd, 0x2122, 0x0459, 0x203a, 0x045a, 0x045c, 0x045b, 0x045f,
  0x00a0, 0x040e, 0x045e, 0x0408, 0x00a4, 0x0490, 0x00a6, 0x00a7,
  0x0401, 0x00a9, 0x0404, 0x00ab, 0x00ac, 0x00ad, 0x00ae, 0x0407,
  0x00b0, 0x00b1, 0x0406, 0x0456, 0x0491, 0x00b5, 0x00b6, 0x00b7,
  0x0451, 0x2116, 0x0454, 0x00bb, 0x0458, 0x0405, 0x0455, 0x0457,
  0x0410, 0x0411, 0x0412, 0x0413, 0x0414, 0x0415, 0x0416, 0x0417,
  0x0418, 0x0419, 0x041a, 0x041b, 0x041c, 0x041d, 0x041e, 0x041f,
  0x0420, 0x0421, 0x0422, 0x0423, 0x0424, 0x0425, 0x0426, 0x0427,
  0x0428, 0x0429, 0x042a, 0x042b, 0x042c, 0x042d, 0x042e, 0x042f,
  0x0430, 0x0431, 0x0432, 0x0433, 0x0434, 0x0435, 0x0436, 0x0437,
  0x0438, 0x0439, 0x043a, 0x043b, 0x043c, 0x043d, 0x043e, 0x043f,
  0x0440, 0x0441, 0x0442, 0x0443, 0x0444, 0x0445, 0x0446, 0x0447,
  0x0448, 0x0449, 0x044a, 0x044b, 0x044c, 0x044d, 0x044e, 0x044f)
    CP1252 <- c(0:127,
  0x20ac, 0xfffd, 0x201a, 0x0192, 0x201e, 0x2026, 0x2020, 0x2021,
  0x02c6, 0x2030, 0x0160, 0x2039, 0x0152, 0xfffd, 0x017d, 0xfffd,
  0xfffd, 0x2018, 0x2019, 0x201c, 0x201d, 0x2022, 0x2013, 0x2014,
  0x02dc, 0x2122, 0x0161, 0x203a, 0x0153, 0xfffd, 0x017e, 0x0178,
                160:255)
    CP1253 <- c(0:127,
  0x20ac, 0xfffd, 0x201a, 0x0192, 0x201e, 0x2026, 0x2020, 0x2021,
  0xfffd, 0x2030, 0xfffd, 0x2039, 0xfffd, 0xfffd, 0xfffd, 0xfffd,
  0xfffd, 0x2018, 0x2019, 0x201c, 0x201d, 0x2022, 0x2013, 0x2014,
  0xfffd, 0x2122, 0xfffd, 0x203a, 0xfffd, 0xfffd, 0xfffd, 0xfffd,
  0x00a0, 0x0385, 0x0386, 0x00a3, 0x00a4, 0x00a5, 0x00a6, 0x00a7,
  0x00a8, 0x00a9, 0xfffd, 0x00ab, 0x00ac, 0x00ad, 0x00ae, 0x2015,
  0x00b0, 0x00b1, 0x00b2, 0x00b3, 0x0384, 0x00b5, 0x00b6, 0x00b7,
  0x0388, 0x0389, 0x038a, 0x00bb, 0x038c, 0x00bd, 0x038e, 0x038f,
  0x0390, 0x0391, 0x0392, 0x0393, 0x0394, 0x0395, 0x0396, 0x0397,
  0x0398, 0x0399, 0x039a, 0x039b, 0x039c, 0x039d, 0x039e, 0x039f,
  0x03a0, 0x03a1, 0xfffd, 0x03a3, 0x03a4, 0x03a5, 0x03a6, 0x03a7,
  0x03a8, 0x03a9, 0x03aa, 0x03ab, 0x03ac, 0x03ad, 0x03ae, 0x03af,
  0x03b0, 0x03b1, 0x03b2, 0x03b3, 0x03b4, 0x03b5, 0x03b6, 0x03b7,
  0x03b8, 0x03b9, 0x03ba, 0x03bb, 0x03bc, 0x03bd, 0x03be, 0x03bf,
  0x03c0, 0x03c1, 0x03c2, 0x03c3, 0x03c4, 0x03c5, 0x03c6, 0x03c7,
  0x03c8, 0x03c9, 0x03ca, 0x03cb, 0x03cc, 0x03cd, 0x03ce, 0xfffd)
    CP1257 <- c(0:127,
  0x20ac, 0xfffd, 0x201a, 0xfffd, 0x201e, 0x2026, 0x2020, 0x2021,
  0xfffd, 0x2030, 0xfffd, 0x2039, 0xfffd, 0x00a8, 0x02c7, 0x00b8,
  0xfffd, 0x2018, 0x2019, 0x201c, 0x201d, 0x2022, 0x2013, 0x2014,
  0xfffd, 0x2122, 0xfffd, 0x203a, 0xfffd, 0x00af, 0x02db, 0xfffd,
  0x00a0, 0xfffd, 0x00a2, 0x00a3, 0x00a4, 0xfffd, 0x00a6, 0x00a7,
  0x00d8, 0x00a9, 0x0156, 0x00ab, 0x00ac, 0x00ad, 0x00ae, 0x00c6,
  0x00b0, 0x00b1, 0x00b2, 0x00b3, 0x00b4, 0x00b5, 0x00b6, 0x00b7,
  0x00f8, 0x00b9, 0x0157, 0x00bb, 0x00bc, 0x00bd, 0x00be, 0x00e6,
  0x0104, 0x012e, 0x0100, 0x0106, 0x00c4, 0x00c5, 0x0118, 0x0112,
  0x010c, 0x00c9, 0x0179, 0x0116, 0x0122, 0x0136, 0x012a, 0x013b,
  0x0160, 0x0143, 0x0145, 0x00d3, 0x014c, 0x00d5, 0x00d6, 0x00d7,
  0x0172, 0x0141, 0x015a, 0x016a, 0x00dc, 0x017b, 0x017d, 0x00df,
  0x0105, 0x012f, 0x0101, 0x0107, 0x00e4, 0x00e5, 0x0119, 0x0113,
  0x010d, 0x00e9, 0x017a, 0x0117, 0x0123, 0x0137, 0x012b, 0x013c,
  0x0161, 0x0144, 0x0146, 0x00f3, 0x014d, 0x00f5, 0x00f6, 0x00f7,
  0x0173, 0x0142, 0x015b, 0x016b, 0x00fc, 0x017c, 0x017e, 0x02d9)
    AdobeSymbol <- c(0:31,
       0x0020, 0x0021, 0x2200, 0x0023, 0x2203, 0x0025, 0x0026, 0x220D,
       0x0028, 0x0029, 0x2217, 0x002B, 0x002C, 0x2212, 0x002E, 0x002F,
       0x0030, 0x0031, 0x0032, 0x0033, 0x0034, 0x0035, 0x0036, 0x0037,
       0x0038, 0x0039, 0x003A, 0x003B, 0x003C, 0x003D, 0x003E, 0x003F,
       0x2245, 0x0391, 0x0392, 0x03A7, 0x0394, 0x0395, 0x03A6, 0x0393,
       0x0397, 0x0399, 0x03D1, 0x039A, 0x039B, 0x039C, 0x039D, 0x039F,
       0x03A0, 0x0398, 0x03A1, 0x03A3, 0x03A4, 0x03A5, 0x03C2, 0x03A9,
       0x039E, 0x03A8, 0x0396, 0x005B, 0x2234, 0x005D, 0x22A5, 0x005F,
       0xF8E5, 0x03B1, 0x03B2, 0x03C7, 0x03B4, 0x03B5, 0x03C6, 0x03B3,
       0x03B7, 0x03B9, 0x03D5, 0x03BA, 0x03BB, 0x03BC, 0x03BD, 0x03BF,
       0x03C0, 0x03B8, 0x03C1, 0x03C3, 0x03C4, 0x03C5, 0x03D6, 0x03C9,
       0x03BE, 0x03C8, 0x03B6, 0x007B, 0x007C, 0x007D, 0x223C, rep.int(0, 33),
       0x20AC, 0x03D2, 0x2032, 0x2264, 0x2044, 0x221E, 0x0192, 0x2663,
       0x2666, 0x2665, 0x2660, 0x2194, 0x2190, 0x2191, 0x2192, 0x2193,
       0x00B0, 0x00B1, 0x2033, 0x2265, 0x00D7, 0x221D, 0x2202, 0x2022,
       0x00F7, 0x2260, 0x2261, 0x2248, 0x2026, 0xF8E6, 0xF8E7, 0x21B5,
       0x2135, 0x2111, 0x211C, 0x2118, 0x2297, 0x2295, 0x2205, 0x2229,
       0x222A, 0x2283, 0x2287, 0x2284, 0x2282, 0x2286, 0x2208, 0x2209,
       0x2220, 0x2207, 0xF6DA, 0xF6D9, 0xF6DB, 0x220F, 0x221A, 0x22C5,
       0x00AC, 0x2227, 0x2228, 0x21D4, 0x21D0, 0x21D1, 0x21D2, 0x21D3,
       0x25CA, 0x2329, 0xF8E8, 0xF8E9, 0xF8EA, 0x2211, 0xF8EB, 0xF8EC,
       0xF8ED, 0xF8EE, 0xF8EF, 0xF8F0, 0xF8F1, 0xF8F2, 0xF8F3, 0xF8F4,
       0,      0x232A, 0x222B, 0x2320, 0xF8F5, 0x2321, 0xF8F6, 0xF8F7,
       0xF8F8, 0xF8F9, 0xF8FA, 0xF8FB, 0xF8FC, 0xF8FD, 0xF8FE, 0)
    M <- cbind(ISOLatin1, ISOLatin2, ISOLatin7, ISOLatin9, Cyrillic, Greek,
               KOI8R, KOI8U,
               CP1250, CP1251, CP1252, CP1253, CP1257, AdobeSymbol)
    rownames(M) <- format.hexmode(0:255)
    storage.mode(M) <- "integer"
    class(M) <- c("noquote", "hexmode")
    M
})

Adobe_glyphs <- local({
    a <- scan(file.path(R.home("share"), "encodings", "Adobe-glyphlist"),
              what=list(adobe="", unicode=""), quiet=TRUE,
              sep=";", comment.char="#")
    a <- as.data.frame(a, stringsAsFactors=FALSE)
    a[order(a$unicode, a$adobe),]
})
#  File src/library/tools/R/index.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2012 The R 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 of the License, 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/

### Miscellaneous indexing functions.

## <NOTE>
## Currently indices are represented as 2-column character matrices.
## To 'merge' indices in the sense of using the values from index B for
## all keys in index A also present in index B, we currently use
##   idx <- match(indA[ , 1L], indB[ , 1L], 0L)
##   indA[which(idx != 0L), 2L] <- indB[idx, 2L]
## which could be abstracted into a function .mergeIndexEntries().
## </NOTE>

### * .build_data_index

.build_data_index <-
function(dataDir, contents)
{
    ## Build an index with information about all available data sets.
    ## See .build_demo_index() for an explanation of what we do here.

    ## <NOTE>
    ## We could also have an interface like
    ##   .build_data_index(dir, contents = NULL)
    ## where @code{dir} is the path to a package's root source dir and
    ## contents is
    ##    Rd_contents(list_files_with_type(file.path(dir, "man"),
    ##                                     "docs")).
    ## </NOTE>

    if(!file_test("-d", dataDir))
        stop(gettextf("directory '%s' does not exist", dataDir),
             domain = NA)
    ## dataFiles <- list_files_with_type(dataDir, "data")
    dataTopics <- list_data_in_pkg(dataDir=dataDir)
    if(!length(dataTopics)) return(matrix("", 0L, 2L))
    names(dataTopics) <- paste0(names(dataTopics), "/")
    datasets <- unlist(dataTopics)
    ## it is possible to have topics that create no object:
    ## BioC's makecdfenv did.
    if(!length(datasets)) return(matrix("", 0L, 2L))
    names(datasets) <- sub("/[^/]*$", "", names(datasets))
    datasets <- sort(datasets)
    dataIndex <- cbind(datasets, "")
    ## Note that NROW(contents) might be 0.
    if(length(datasets) && NROW(contents)) {
        aliasIndices <-
            rep(1 : NROW(contents), sapply(contents$Aliases, length))
        idx <- match(datasets, unlist(contents$Aliases), 0L)
        dataIndex[which(idx != 0L), 2L] <-
            contents[aliasIndices[idx], "Title"]
    }
    if(length(datasets))
        dataIndex[, 1L] <-
            as.vector(ifelse(datasets == names(datasets), datasets,
                             paste0(datasets, " (", names(datasets), ")")))
    dimnames(dataIndex) <- NULL
    dataIndex
}

### * .build_demo_index

.build_demo_index <-
function(demoDir)
{
    ## Build an index with information about all available demos.

    ## <NOTE>
    ## We use both the contents of @file{00Index} (if possible) and the
    ## information which demos are actually available to build the real
    ## demo index.
    ## This ensures that demo() really lists all *available* demos, even
    ## if some might be 'undocumented', i.e., without index information.
    ## Use .check_demo_index() to check whether available demo code and
    ## docs are in sync.
    ## </NOTE>

    if(!file_test("-d", demoDir))
        stop(gettextf("directory '%s' does not exist", demoDir),
             domain = NA)
    demoFiles <- list_files_with_type(demoDir, "demo")
    demoTopics <- unique(basename(file_path_sans_ext(demoFiles)))
    if(!length(demoTopics)) return(matrix("", 0L, 2L))
    demoIndex <- cbind(demoTopics, "")
    if(file_test("-f", INDEX <- file.path(demoDir, "00Index"))) {
        demoEntries <- tryCatch(read.00Index(INDEX), error = identity)
        if(inherits(demoEntries, "error"))
            warning(gettextf("cannot read index information in file '%s'",
                             INDEX),
                    domain = NA)
        else {
            idx <- match(demoTopics, demoEntries[ , 1L], 0L)
            demoIndex[which(idx != 0L), 2L] <- demoEntries[idx, 2L]
        }
    }
    dimnames(demoIndex) <- NULL
    demoIndex
}

### * .check_demo_index

.check_demo_index <-
function(demoDir)
{
    if(!file_test("-d", demoDir))
        stop(gettextf("directory '%s' does not exist", demoDir),
             domain = NA)
    info_from_build <- .build_demo_index(demoDir)
    info_from_index <-
        tryCatch(read.00Index(file.path(demoDir, "00Index")),
                 error = function(e)
                 stop(gettextf("cannot read index information in file '%s'",
                               file.path(demoDir, "00Index")),
                      domain = NA))
    bad_entries <-
        list(missing_from_index =
             info_from_build[grep("^[[:space:]]*$",
                                  info_from_build[ , 2L]),
                             1L],
             missing_from_demos =
             info_from_index[!info_from_index[ , 1L]
                             %in% info_from_build[ , 1L],
                             1L])
    class(bad_entries) <- "check_demo_index"
    bad_entries
}

print.check_demo_index <-
function(x, ...)
{
    if(length(x$missing_from_index)) {
        writeLines("Demos with missing or empty index information:")
        print(x$missing_from_index, ...)
    }
    if(length(x$missing_from_demos)) {
        writeLines("Demo index entries without corresponding demo:")
        print(x$missing_from_demos, ...)
    }
    invisible(x)
}

### * .build_hsearch_index

.build_hsearch_index <-
function(contents, packageName, defaultEncoding = NULL)
{
    ## Build an index of the Rd contents in 'contents', of a package
    ## named 'packageName' in a form useful for help.search().
    ## As from 2.3.0 the installation directory is no longer recorded,
    ## but the format is kept for back-compatibility.

    dbAliases <- dbConcepts <- dbKeywords <-
        matrix(character(), ncol = 3L)

    if((nr <- NROW(contents)) > 0L) {
        ## IDs are used for indexing the Rd objects in the help.search
        ## db.
        IDs <- seq_len(nr)
        if(!is.data.frame(contents)) {
            colnames(contents) <-
                c("Name", "Aliases", "Title", "Keywords")
            base <- contents[, c("Name", "Title"), drop = FALSE]
            ## If the contents db is not a data frame, then it has the
            ## aliases collapsed.  Split again as we need the first
            ## alias as the help topic to indicate for matching Rd
            ## objects.
            aliases <- strsplit(contents[, "Aliases"], " +")
            ## Don't do this for keywords though, as these might be
            ## non-standard (and hence contain white space ...).
            encoding <- NULL
        }
        else {
            base <- as.matrix(contents[, c("Name", "Title")])
            aliases <- contents[, "Aliases"]
            encoding <- contents$Encoding # may not be there ...
        }
        if(is.null(encoding))
            encoding <- character(length = nr)
        if(!is.null(defaultEncoding))
            encoding[!nzchar(encoding)] <- defaultEncoding
        keywords <- contents[, "Keywords"]
        ## We create 4 character matrices (cannot use data frames for
        ## efficiency reasons): 'dbBase' holds all character string
        ## data; 'dbAliases', 'dbConcepts' and 'dbKeywords' hold
        ## character vector data in a 3-column character matrix format
        ## with entry, ID of the Rd object the entry comes from, and the
        ## package the object comes from.  The latter is useful when
        ## subscripting the help.search db according to package.
        dbBase <- cbind(packageName, "", IDs, base,
                        topic = sapply(aliases, "[", 1L), encoding)
        ## If there are no aliases at all, cbind() below would give
        ## matrix(packageName, ncol = 1L).  (Of course, Rd objects
        ## without aliases are useless ...)
        if(length(tmp <- unlist(aliases)))
            dbAliases <-
                cbind(tmp, rep.int(IDs, sapply(aliases, length)),
                      packageName)
        ## And similarly if there are no keywords at all.
        if(length(tmp <- unlist(keywords)))
            dbKeywords <-
                cbind(tmp, rep.int(IDs, sapply(keywords, length)),
                      packageName)
        ## Finally, concepts are a feature added in R 1.8 ...
        if("Concepts" %in% colnames(contents)) {
            concepts <- contents[, "Concepts"]
            if(length(tmp <- unlist(concepts)))
                dbConcepts <-
                    cbind(tmp, rep.int(IDs, sapply(concepts, length)),
                          packageName)
        }
    }
    else
        dbBase <- matrix(character(), ncol = 7L)

    colnames(dbBase) <-
        c("Package", "LibPath", "ID", "name", "title", "topic",
          "Encoding")
    colnames(dbAliases) <-
        c("Aliases", "ID", "Package")
    colnames(dbKeywords) <-
        c("Keywords", "ID", "Package")
    colnames(dbConcepts) <-
        c("Concepts", "ID", "Package")

    list(dbBase, dbAliases, dbKeywords, dbConcepts)
}

### * .build_links_index

.build_links_index <-
function(contents, package)
{
    if(length(contents)) {
        aliases <- contents$Aliases
        lens <- sapply(aliases, length)
        files <- sub("\\.[Rr]d$", "\\.html", contents$File)
        structure(file.path("../..", package, "html", rep.int(files, lens)),
                  names = unlist(aliases))
    } else character()
}


### mode: outline-minor ***
### outline-regexp: "### [*]+" ***
### End: ***
#  File src/library/tools/R/install.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2014 The R Core Team
#
# NB: also copyright dates in Usages.
#
#  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 of the License, 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/

#### R based engine for  R CMD INSTALL SHLIB Rprof
####

##' @param args

## R developers can use this to debug the function by running it
## directly as tools:::.install_packages(args), where the args should
## be what commandArgs(TRUE) would return, that is a character vector
## of (space-delimited) terms that would be passed to R CMD INSTALL.  E.g.
##
## tools:::.install_packages(c("--preclean", "--no-multiarch", "tree"))

##' @return ...
.install_packages <- function(args = NULL)
{
    ## calls system() on Windows for
    ## sh (configure.win/cleanup.win) make zip

    dir.exists <- function(x) !is.na(isdir <- file.info(x)$isdir) & isdir

    ## global variables
    curPkg <- character() # list of packages in current pkg
    lockdir <- ""
    is_first_package <- TRUE
    stars <- "*"

    ## Need these here in case of an early error, e.g. missing etc/Makeconf
    tmpdir <- ""
    clean_on_error <- TRUE
    do_exit_on_error <- function()
    {
        ## If we are not yet processing a package, we will not have
        ## set curPkg
        if(clean_on_error && length(curPkg)) {
            pkgdir <- file.path(lib, curPkg)
            if (nzchar(pkgdir) && dir.exists(pkgdir) &&
                is_subdir(pkgdir, lib)) {
                starsmsg(stars, "removing ", sQuote(pkgdir))
                unlink(pkgdir, recursive = TRUE)
            }

            if (nzchar(lockdir) &&
                dir.exists(lp <- file.path(lockdir, curPkg)) &&
                is_subdir(lp, lockdir)) {
                starsmsg(stars, "restoring previous ", sQuote(pkgdir))
                if (WINDOWS) {
                    file.copy(lp, dirname(pkgdir), recursive = TRUE,
                              copy.date = TRUE)
                    unlink(lp, recursive = TRUE)
                } else {
                    ## some shells require that they be run in a known dir
                    setwd(startdir)
                    system(paste("mv", shQuote(lp), shQuote(pkgdir)))
                }
            }
        }

        do_cleanup()
        q("no", status = 1, runLast = FALSE)
    }

    do_cleanup <- function()
    {
        if(nzchar(tmpdir)) do_cleanup_tmpdir()
        if (!is_first_package) {
            ## Only need to do this in case we successfully installed
            ## at least one package
            if (lib == .Library && "html" %in% build_help_types)
                utils::make.packages.html(.Library, docdir = R.home("doc"))
        }
        if (nzchar(lockdir)) unlink(lockdir, recursive = TRUE)
    }

    do_cleanup_tmpdir <- function()
    {
        ## Solaris will not remove any directory in the current path
        setwd(startdir)
        if (dir.exists(tmpdir)) unlink(tmpdir, recursive=TRUE)
    }

    on.exit(do_exit_on_error())
    WINDOWS <- .Platform$OS.type == "windows"

    MAKE <- Sys.getenv("MAKE") # FIXME shQuote, default?
    rarch <- Sys.getenv("R_ARCH") # unix only
    if (WINDOWS && nzchar(.Platform$r_arch))
        rarch <- paste0("/", .Platform$r_arch)
    test_archs <- rarch

    SHLIB_EXT <- if (WINDOWS) ".dll" else {
        ## can we do better?
        mconf <- file.path(R.home(), paste0("etc", rarch), "Makeconf")
        ## PCRE needed for Debian arm* platforms
        sub(".*= ", "", grep("^SHLIB_EXT", readLines(mconf), value = TRUE,
                             perl = TRUE))
    }

    options(warn = 1)
    invisible(Sys.setlocale("LC_COLLATE", "C")) # discard output

    if (WINDOWS) {
        rhome <- chartr("\\", "/", R.home())
        ## These might be needed for configure.win and Make{file,vars}.win
        ## Some people have *assumed* that R_HOME uses /
        Sys.setenv(R_HOME = rhome)
        if (nzchar(rarch)) Sys.setenv(R_ARCH = rarch, R_ARCH_BIN = rarch)
    }

    Usage <- function() {
        cat("Usage: R CMD INSTALL [options] pkgs",
            "",
            "Install the add-on packages specified by pkgs.  The elements of pkgs can",
            "be relative or absolute paths to directories with the package",
            "sources, or to gzipped package 'tar' archives.  The library tree",
            "to install to can be specified via '--library'.  By default, packages are",
            "installed in the library tree rooted at the first directory in",
            ".libPaths() for an R session run in the current environment",
            "",
            "Options:",
            "  -h, --help		print short help message and exit",
            "  -v, --version		print INSTALL version info and exit",
            "  -c, --clean		remove files created during installation",
            "      --preclean	remove files created during a previous run",
	    "  -d, --debug		turn on debugging messages",
            if(WINDOWS) "			and build a debug DLL",
            "  -l, --library=LIB	install packages to library tree LIB",
            "      --no-configure    do not use the package's configure script",
            "      --no-docs		do not install HTML, LaTeX or examples help",
            "      --html		build HTML help",
            "      --no-html		do not build HTML help",
            "      --latex      	install LaTeX help",
            "      --example		install R code for help examples",
            "      --fake		do minimal install for testing purposes",
            "      --no-lock		install on top of any existing installation",
            "			without using a lock directory",
            "      --lock		use a per-library lock directory (default)",
            "      --pkglock		use a per-package lock directory",
            "      			(default for a single package)",
            "      --build    	build binaries of the installed package(s)",
            "      --install-tests	install package-specific tests (if any)",
            "      --no-R, --no-libs, --no-data, --no-help, --no-demo, --no-exec,",
            "      --no-inst",
            "			suppress installation of the specified part of the",
            "			package for testing or other special purposes",
            "      --no-multiarch	build only the main architecture",
            "      --libs-only	only install the libs directory",
            "      --data-compress=	none, gzip (default), bzip2 or xz compression",
            "			to be used for lazy-loading of data",
            "      --resave-data	re-save data files as compactly as possible",
            "      --compact-docs	re-compress PDF files under inst/doc",
            "      --with-keep.source",
            "      --without-keep.source",
            "			use (or not) 'keep.source' for R code",
            "      --byte-compile	byte-compile R code",
            "      --no-byte-compile	do not byte-compile R code",
            "      --no-test-load	skip test of loading installed package",
            "      --no-clean-on-error	do not remove installed package on error",
            "      --merge-multiarch	multi-arch by merging (from a single tarball only)",
           "\nfor Unix",
            "      --configure-args=ARGS",
            "			set arguments for the configure scripts (if any)",
            "      --configure-vars=VARS",
            "			set variables for the configure scripts (if any)",
            "      --dsym            (OS X only) generate dSYM directory",
            "\nand on Windows only",
            "      --force-biarch	attempt to build both architectures",
            "			even if there is a non-empty configure.win",
            "      --compile-both	compile both architectures on 32-bit Windows",
            "",
            "Which of --html or --no-html is the default depends on the build of R:",
            paste0("for this one it is ",
		   if(static_html) "--html" else "--no-html", "."),
            "",
            "Report bugs at bugs.r-project.org .", sep = "\n")
    }


    # Check whether dir is a subdirectory of parent,
    # to protect against malicious package names like ".." below
    # Assumes that both directories exist

    is_subdir <- function(dir, parent)
        normalizePath(parent) == normalizePath(file.path(dir, ".."))

    fullpath <- function(dir)
    {
        owd <- setwd(dir)
        full <- getwd()
        setwd(owd)
        full
    }

    ## used for LazyData, KeepSource, ByteCompile, Biarch
    parse_description_field <- function(desc, field, default = TRUE)
    {
        tmp <- desc[field]
        if (is.na(tmp)) default
        else switch(tmp,
                    "yes"=, "Yes" =, "true" =, "True" =, "TRUE" = TRUE,
                    "no" =, "No" =, "false" =, "False" =, "FALSE" = FALSE,
                    ## default
                    errmsg("invalid value of ", field, " field in DESCRIPTION")
                    )
    }

    starsmsg <- function(stars, ...)
        message(stars, " ", ..., domain = NA)

    errmsg <- function(...)
    {
        message("ERROR: ", ..., domain = NA)
        do_exit_on_error()
    }

    pkgerrmsg <- function(msg, pkg)
    {
        message("ERROR: ", msg, " for package ", sQuote(pkg), domain = NA)
        do_exit_on_error()
    }

    ## 'pkg' is the absolute path to package sources.
    do_install <- function(pkg)
    {
        if (WINDOWS && grepl("\\.zip$", pkg)) {
            pkg_name <- basename(pkg)
            pkg_name <- sub("\\.zip$", "", pkg_name)
            pkg_name <- sub("_[0-9.-]+$", "", pkg_name)
            utils:::unpackPkgZip(pkg, pkg_name, lib, libs_only)
            return()
        }

        setwd(pkg)
        ## We checked this exists, but not that it is readable
        desc <- tryCatch(read.dcf(fd <- file.path(pkg, "DESCRIPTION")),
                         error = identity)
        if(inherits(desc, "error") || !length(desc))
            stop(gettextf("error reading file '%s'", fd),
                 domain = NA, call. = FALSE)
        desc <- desc[1L,]
        ## Let's see if we have a bundle
        if (!is.na(desc["Bundle"])) {
            stop("this seems to be a bundle -- and they are defunct")
        } else {
            pkg_name <- desc["Package"]
            if (is.na(pkg_name)) errmsg("no 'Package' field in 'DESCRIPTION'")
            curPkg <<- pkg_name
        }

        instdir <- file.path(lib, pkg_name)
        Sys.setenv(R_PACKAGE_NAME = pkg_name, R_PACKAGE_DIR = instdir)
        status <- .Rtest_package_depends_R_version()
        if (status) do_exit_on_error()

        dir.create(instdir, recursive = TRUE, showWarnings = FALSE)
        if (!dir.exists(instdir)) {
            message("ERROR: unable to create ", sQuote(instdir), domain = NA)
            do_exit_on_error()
        }

        if (!is_subdir(instdir, lib)) {
            message("ERROR: ", sQuote(pkg_name), " is not a legal package name",
                    domain = NA)
            do_exit_on_error()
        }

        ## Make sure we do not attempt installing to srcdir.
        owd <- setwd(instdir)
        if (owd == getwd()) pkgerrmsg("cannot install to srcdir", pkg_name)
        setwd(owd)

        ## Figure out whether this is a source or binary package.
        is_source_package <- is.na(desc["Built"])

        if (is_source_package) {
            ## Find out if C++11 is requested in DESCRIPTION file
            sys_requires <- desc["SystemRequirements"]
            if (!is.na(sys_requires)) {
                sys_requires <- unlist(strsplit(sys_requires, ","))
                if(any(grepl("^[[:space:]]*C[+][+]11[[:space:]]*$",
                             sys_requires, ignore.case=TRUE))) {
                    Sys.setenv("R_PKG_CXX_STD"="CXX11")
                    on.exit(Sys.unsetenv("R_PKG_CXX_STD"))
                }
            }
        }

        if (!is_first_package) cat("\n")

        if (is_source_package)
            do_install_source(pkg_name, instdir, pkg, desc)
        else
            do_install_binary(pkg_name, instdir, desc)

        ## Add read permission to all, write permission to owner
        ## If group-write permissions were requested, set them
        .Call(dirchmod, instdir, group.writable)
        is_first_package <<- FALSE

        if (tar_up) { # Unix only
            starsmsg(stars, "creating tarball")
            version <- desc["Version"]
            filename <- if (!grepl("darwin", R.version$os)) {
                paste0(pkg_name, "_", version, "_R_",
                       Sys.getenv("R_PLATFORM"), ".tar.gz")
            } else {
                paste0(pkg_name, "_", version,".tgz")
            }
            filepath <- file.path(startdir, filename)
            owd <- setwd(lib)
            res <- utils::tar(filepath, curPkg, compression = "gzip",
                              compression_level = 9L,
                              tar = Sys.getenv("R_INSTALL_TAR"))
            if (res)
                errmsg(sprintf("packaging into %s failed", sQuote(filename)))
            message("packaged installation of ",
                    sQuote(pkg_name), " as ",
                    sQuote(paste0(filename, ".gz")),
                    domain = NA)
            setwd(owd)
        }

        if (zip_up) { # Windows only
            starsmsg(stars, "MD5 sums")
            .installMD5sums(instdir)
            ## we could use utils::zip() here.
            ZIP <- "zip"                # Windows only
            version <- desc["Version"]
            filename <- paste0(pkg_name, "_", version, ".zip")
            filepath <- shQuote(file.path(startdir, filename))
            ## system(paste("rm -f", filepath))
            unlink(filepath)
            owd <- setwd(lib)
            res <- system(paste(shQuote(ZIP), "-r9Xq", filepath,
                                paste(curPkg, collapse = " ")))
            setwd(owd)
            if (res)
                message("running 'zip' failed", domain = NA)
            else
                message("packaged installation of ",
                        sQuote(pkg_name), " as ", filename, domain = NA)
        }
        if (Sys.getenv("_R_INSTALL_NO_DONE_") != "yes") {
            ## message("", domain = NA)  # ensure next starts on a new line, for R CMD check
            starsmsg(stars, "DONE (", pkg_name, ")")
        }

        curPkg <<- character()
    }


    ## Unix only
    do_install_binary <- function(pkg, instdir, desc)
    {
        starsmsg(stars, "installing *binary* package ", sQuote(pkg), " ...")

        if (file.exists(file.path(instdir, "DESCRIPTION"))) {
            if (nzchar(lockdir))
                system(paste("mv", shQuote(instdir),
                             shQuote(file.path(lockdir, pkg))))
            dir.create(instdir, recursive = TRUE, showWarnings = FALSE)
        }
        TAR <- Sys.getenv("TAR", 'tar')
        res <- system(paste("cp -R .", shQuote(instdir),
                            "|| (", TAR, "cd - .| (cd", shQuote(instdir), "&&", TAR, "-xf -))"
                            ))
        if (res) errmsg("installing binary package failed")

        if (tar_up) {
            starsmsg(stars, sQuote(pkg),
                     " was already a binary package and will not be rebuilt")
            tar_up <- FALSE
        }
    }

    ## to be run from package source directory
    run_clean <- function()
    {
        if (dir.exists("src") && length(dir("src", all.files = TRUE) > 2L)) {
            if (WINDOWS) archs <- c("i386", "x64")
            else {
                wd2 <- setwd(file.path(R.home("bin"), "exec"))
                archs <- Sys.glob("*")
                setwd(wd2)
            }
            if(length(archs))
                for(arch in archs) {
                    ss <- paste("src", arch, sep = "-")
                    ## it seems fixing permissions is sometimes needed
                    .Call(dirchmod, ss, group.writable)
                    unlink(ss, recursive = TRUE)
                }

            owd <- setwd("src")
            if (WINDOWS) {
                if (file.exists("Makefile.win"))
                    system(paste(MAKE, "-f Makefile.win clean"))
                else
                    unlink(c("Makedeps",
                             Sys.glob("*_res.rc"),
                             Sys.glob("*.[do]")))
                    # system("rm -f *_res.rc *.o *.d Makedeps")
            } else {
                if (file.exists("Makefile")) system(paste(MAKE, "clean"))
                else ## we will be using SHLIB --preclean
                    unlink(Sys.glob(paste0("*", SHLIB_EXT)))
            }
            setwd(owd)
        }
        if (WINDOWS) {
            if (file.exists("cleanup.win")) system("sh ./cleanup.win")
        } else if (file_test("-x", "cleanup")) system("./cleanup")
        else if (file.exists("cleanup"))
            warning("'cleanup' exists but is not executable -- see the 'R Installation and Administration Manual'", call. = FALSE)

    }

    do_install_source <- function(pkg_name, instdir, pkg_dir, desc)
    {
        Sys.setenv("R_INSTALL_PKG" = pkg_name)
        on.exit(Sys.unsetenv("R_INSTALL_PKG"))
        shlib_install <- function(instdir, arch)
        {
            ## install.libs.R allows customization of the libs installation process
            if (file.exists("install.libs.R")) {
                message("installing via 'install.libs.R' to ", instdir,
                        domain = NA)
                ## the following variables are defined to be available,
                ## and to prevent abuse we don't expose anything else
                local.env <- local({ SHLIB_EXT <- SHLIB_EXT
                                     R_PACKAGE_DIR <- instdir
                                     R_PACKAGE_NAME <- pkg_name
                                     R_PACKAGE_SOURCE <- pkg_dir
                                     R_ARCH <- arch
                                     WINDOWS <- WINDOWS
                                     environment()})
                parent.env(local.env) <- .GlobalEnv
                source("install.libs.R", local = local.env)
                return(TRUE)
            }
            ## otherwise proceed with the default which is to just copy *${SHLIB_EXT}
            files <- Sys.glob(paste0("*", SHLIB_EXT))
            if (length(files)) {
                libarch <- if (nzchar(arch)) paste0("libs", arch) else "libs"
                dest <- file.path(instdir, libarch)
                message('installing to ', dest, domain = NA)
                dir.create(dest, recursive = TRUE, showWarnings = FALSE)
                file.copy(files, dest, overwrite = TRUE)
                ## not clear if this is still necessary, but sh version did so
		if (!WINDOWS)
		    Sys.chmod(file.path(dest, files), dmode)
		## OS X does not keep debugging symbols in binaries
		## anymore so optionally we can create dSYMs. This is
		## important since we will blow away .o files so there
		## is no way to create it later.

		if (dsym && length(grep("^darwin", R.version$os)) ) {
		    message(gettextf("generating debug symbols (%s)", "dSYM"),
                            domain = NA)
		    dylib <- Sys.glob(paste0(dest, "/*", SHLIB_EXT))
                    for (file in dylib) system(paste0("dsymutil ", file))
		}

                if(config_val_to_logical(Sys.getenv("_R_SHLIB_BUILD_OBJECTS_SYMBOL_TABLES_",
                                                    "TRUE"))
                   && file_test("-f", "symbols.rds")) {
                    file.copy("symbols.rds", dest)
                }
            }
        }

        ## This is only called for Makevars[.win], so assume it
        ## does create a shlib: not so reliably reported on Windows
        ## Note though that it may not create pkg_name.dll, and
        ## graph does not.
        run_shlib <- function(pkg_name, srcs, instdir, arch)
        {
            args <- c(shargs, "-o", paste0(pkg_name, SHLIB_EXT), srcs)
            if (WINDOWS && debug) args <- c(args, "--debug")
            if (debug) message("about to run ",
                               "R CMD SHLIB ", paste(args, collapse = " "),
                               domain = NA)
            if (.shlib_internal(args) == 0L) {
                if(WINDOWS && !file.exists("install.libs.R")
                   && !length(Sys.glob("*.dll"))) {
                    message("no DLL was created")
                    return(TRUE)
                }
                shlib_install(instdir, arch)
                return(FALSE)
            } else return(TRUE)
        }

        ## Make the destination directories available to the developer's
        ## installation scripts (e.g. configure)
        Sys.setenv(R_LIBRARY_DIR = lib)

        if (nzchar(lib0)) {
            ## FIXME: is this needed?
            ## set R_LIBS to include the current installation directory
            rlibs <- Sys.getenv("R_LIBS")
            rlibs <- if (nzchar(rlibs)) paste(lib, rlibs, sep = .Platform$path.sep) else lib
            Sys.setenv(R_LIBS = rlibs)
            ## This is needed
            .libPaths(c(lib, .libPaths()))
        }

        Type <- desc["Type"]
        if (!is.na(Type) && Type == "Frontend") {
            if (WINDOWS) errmsg("'Frontend' packages are Unix-only")
            starsmsg(stars, "installing *Frontend* package ", sQuote(pkg_name), " ...")
            if (preclean) system(paste(MAKE, "clean"))
            if (use_configure) {
                if (file_test("-x", "configure")) {
                    res <- system(paste(paste(configure_vars, collapse = " "),
                                        "./configure",
                                        paste(configure_args, collapse = " ")))
                    if (res) pkgerrmsg("configuration failed", pkg_name)
                } else if (file.exists("configure"))
                    errmsg("'configure' exists but is not executable -- see the 'R Installation and Administration Manual'")
            }
            if (file.exists("Makefile"))
                if (system(MAKE)) pkgerrmsg("make failed", pkg_name)
            if (clean) system(paste(MAKE, "clean"))
            return()
        }

        if (!is.na(Type) && Type == "Translation")
            errmsg("'Translation' packages are defunct")

        OS_type <- desc["OS_type"]
        if (WINDOWS) {
            if ((!is.na(OS_type) && OS_type == "unix") && !fake)
                errmsg(" Unix-only package")
        } else {
            if ((!is.na(OS_type) && OS_type == "windows") && !fake)
                errmsg(" Windows-only package")
        }

	if(group.writable) { ## group-write modes if requested:
	    fmode <- "664"
	    dmode <- "775"
	} else {
	    fmode <- "644"
	    dmode <- "755"
	}

        ## At this point we check that we have the dependencies we need.
        ## We cannot use installed.packages() as other installs might be
        ## going on in parallel

        pkgInfo <- .split_description(.read_description("DESCRIPTION"))
        pkgs <- unique(c(names(pkgInfo$Depends), names(pkgInfo$Imports),
                         names(pkgInfo$LinkingTo)))
        if (length(pkgs)) {
            miss <- character()
            for (pkg in pkgs) {
                if(!length(find.package(pkg, quiet = TRUE)))
                    miss <- c(miss, pkg)
            }
            if (length(miss) > 1)
                 pkgerrmsg(sprintf("dependencies %s are not available",
                                   paste(sQuote(miss), collapse = ", ")),
                           pkg_name)
            else if (length(miss))
                pkgerrmsg(sprintf("dependency %s is not available",
                                  sQuote(miss)), pkg_name)
         }

        starsmsg(stars, "installing *source* package ",
                 sQuote(pkg_name), " ...")

        stars <- "**"

        res <- checkMD5sums(pkg_name, getwd())
        if(!is.na(res) && res) {
            starsmsg(stars,
                     gettextf("package %s successfully unpacked and MD5 sums checked",
                              sQuote(pkg_name)))
        }

        if (file.exists(file.path(instdir, "DESCRIPTION"))) {
            ## Back up a previous version
            if (nzchar(lockdir)) {
                if (debug) starsmsg(stars, "backing up earlier installation")
                if(WINDOWS) {
                    file.copy(instdir, lockdir, recursive = TRUE,
                              copy.date = TRUE)
                    if (more_than_libs) unlink(instdir, recursive = TRUE)
                } else if (more_than_libs)
                    system(paste("mv", shQuote(instdir),
                                 shQuote(file.path(lockdir, pkg_name))))
                else
                    file.copy(instdir, lockdir, recursive = TRUE,
                              copy.date = TRUE)
            } else if (more_than_libs) unlink(instdir, recursive = TRUE)
            dir.create(instdir, recursive = TRUE, showWarnings = FALSE)
        }

        if (preclean) run_clean()

        if (use_configure) {
            if (WINDOWS) {
                if (file.exists("configure.win")) {
                    res <- system("sh ./configure.win")
                    if (res) pkgerrmsg("configuration failed", pkg_name)
                } else if (file.exists("configure"))
                    message("\n",
                            "   **********************************************\n",
                            "   WARNING: this package has a configure script\n",
                            "         It probably needs manual configuration\n",
                            "   **********************************************\n\n", domain = NA)
            } else {
                ## FIXME: should these be quoted?
                if (file_test("-x", "configure")) {
                    cmd <- paste(paste(configure_vars, collapse = " "),
                                 "./configure",
                                 paste(configure_args, collapse = " "))
                    if (debug) message("configure command: ", sQuote(cmd),
                                       domain = NA)
                    ## in case the configure script calls SHLIB (some do)
                    cmd <- paste("_R_SHLIB_BUILD_OBJECTS_SYMBOL_TABLES_=false",
                                 cmd)
                    res <- system(cmd)
                    if (res) pkgerrmsg("configuration failed", pkg_name)
                }  else if (file.exists("configure"))
                    errmsg("'configure' exists but is not executable -- see the 'R Installation and Administration Manual'")
            }
        }


        if (more_than_libs) {
            for (f in c("NAMESPACE", "LICENSE", "LICENCE", "NEWS"))
                if (file.exists(f)) {
                    file.copy(f, instdir, TRUE)
		    Sys.chmod(file.path(instdir, f), fmode)
                }

            res <- try(.install_package_description('.', instdir))
            if (inherits(res, "try-error"))
                pkgerrmsg("installing package DESCRIPTION failed", pkg_name)
            if (!file.exists(namespace <- file.path(instdir, "NAMESPACE")) ) {
                if(dir.exists("R"))
                    errmsg("a 'NAMESPACE' file is required")
                else writeLines("## package without R code", namespace)
            }
        }

        if (install_libs && dir.exists("src") &&
            length(dir("src", all.files = TRUE) > 2L)) {
            starsmsg(stars, "libs")
            if (!file.exists(file.path(R.home("include"), "R.h")))
                ## maybe even an error?  But installing Fortran-based packages should work
                warning("R include directory is empty -- perhaps need to install R-devel.rpm or similar", call. = FALSE)
            has_error <- FALSE
            linkTo <- pkgInfo$LinkingTo
            if (!is.null(linkTo)) {
                lpkgs <- sapply(linkTo, function(x) x[[1L]])
                ## we checked that these were all available earlier,
                ## but be cautious in case this changed.
                paths <- find.package(lpkgs, quiet = TRUE)
                bpaths <- basename(paths)
                if (length(paths)) {
                    ## check any version requirements
                    have_vers <-
                        (vapply(linkTo, length, 1L) > 1L) & lpkgs %in% bpaths
                    for (z in linkTo[have_vers]) {
                        p <- z[[1L]]
                        path <- paths[bpaths %in% p]
                        current <- readRDS(file.path(path, "Meta", "package.rds"))$DESCRIPTION["Version"]
                        target <- as.numeric_version(z$version)
                        if (!do.call(z$op, list(as.numeric_version(current), target)))
                            stop(gettextf("package %s %s was found, but %s %s is required by %s",
                                          sQuote(p), current, z$op,
                                          target, sQuote(pkgname)),
                                 call. = FALSE, domain = NA)
                    }
                    clink_cppflags <- paste(paste0('-I"', paths, '/include"'),
                                            collapse = " ")
                    Sys.setenv(CLINK_CPPFLAGS = clink_cppflags)
                }
            } else clink_cppflags <- ""
            libdir <- file.path(instdir, paste0("libs", rarch))
            dir.create(libdir, showWarnings = FALSE)
            if (WINDOWS) {
                owd <- setwd("src")
                makefiles <- character()
                if (!is.na(f <- Sys.getenv("R_MAKEVARS_USER", NA))) {
                    if (file.exists(f))  makefiles <- f
                } else if (file.exists(f <- path.expand("~/.R/Makevars.win")))
                    makefiles <- f
                else if (file.exists(f <- path.expand("~/.R/Makevars")))
                    makefiles <- f
                if (file.exists("Makefile.win")) {
                    makefiles <- c("Makefile.win", makefiles)
                    message("  running 'src/Makefile.win' ...", domain = NA)
                    res <- system(paste("make --no-print-directory",
                                        paste("-f", shQuote(makefiles), collapse = " ")))
                    if (res == 0) shlib_install(instdir, rarch)
                    else has_error <- TRUE
                } else { ## no src/Makefile.win
                    srcs <- dir(pattern = "\\.([cfmM]|cc|cpp|f90|f95|mm)$",
                                all.files = TRUE)
                    archs <- if (!force_both && !grepl(" x64 ", win.version()))
                        "i386"
                    else {
                        ## see what is installed
                        ## NB, not R.home("bin")
                        f  <- dir(file.path(R.home(), "bin"))
                        f[f %in% c("i386", "x64")]
                    }
                    one_only <- !multiarch
                    if(!one_only && file.exists("../configure.win")) {
                        ## for now, hardcode some exceptions
                        ## These are packages which have arch-independent
                        ## code in configure.win
                        if(!pkg_name %in% c("AnalyzeFMRI", "CORElearn",
                                            "PearsonDS", "PKI", "RGtk2",
                                            "RNetCDF", "RODBC", "RSclient",
                                            "Rcpp", "Runuran", "SQLiteMap",
                                            "XML", "arulesSequences",
                                            "cairoDevice", "diversitree",
                                            "foreign", "fastICA", "glmnet",
                                            "gstat", "igraph", "jpeg", "png",
                                            "proj4", "randtoolbox", "rgdal",
                                            "rngWELL", "rphast", "rtfbs",
                                            "sparsenet", "tcltk2", "tiff",
                                            "udunits2"))
                            one_only <- sum(nchar(readLines("../configure.win", warn = FALSE), "bytes")) > 0
                        if(one_only && !force_biarch) {
                            if(parse_description_field(desc, "Biarch", FALSE))
                                force_biarch <- TRUE
                            else
                                warning("this package has a non-empty 'configure.win' file,\nso building only the main architecture\n", call. = FALSE, domain = NA)
                        }
                    }
                    if(force_biarch) one_only <- FALSE
                    if(one_only || length(archs) < 2L)
                        has_error <- run_shlib(pkg_name, srcs, instdir, rarch)
                    else {
                        setwd(owd)
                        test_archs <- archs
                        for(arch in archs) {
                            message("", domain = NA) # a blank line
                            starsmsg("***", "arch - ", arch)
                            ss <- paste("src", arch, sep = "-")
                            dir.create(ss, showWarnings = FALSE)
                            file.copy(Sys.glob("src/*"), ss, recursive = TRUE)
                            ## avoid read-only files/dir such as nested .svn
			    .Call(dirchmod, ss, group.writable)
                            setwd(ss)

                            ra <- paste0("/", arch)
                            Sys.setenv(R_ARCH = ra, R_ARCH_BIN = ra)
                            has_error <- run_shlib(pkg_name, srcs, instdir, ra)
                            setwd(owd)
                            if (has_error) break
                        }
                    }
                }
                setwd(owd)
            } else { # not WINDOWS
                if (file.exists("src/Makefile")) {
                    arch <- substr(rarch, 2, 1000)
                    starsmsg(stars, "arch - ", arch)
                    owd <- setwd("src")
                    system_makefile <-
                        file.path(R.home(), paste0("etc", rarch), "Makeconf")
                    site <- Sys.getenv("R_MAKEVARS_SITE", NA)
                    if (is.na(site)) site <- file.path(paste0(R.home("etc"), rarch), "Makevars.site")
                    makefiles <- c(system_makefile,
                                   if(file.exists(site)) site,
                                   "Makefile")
                    if (!is.na(f <- Sys.getenv("R_MAKEVARS_USER", NA))) {
                        if (file.exists(f))  makefiles <- c(makefiles, f)
                    } else if (file.exists(f <- path.expand(paste("~/.R/Makevars",
                                                                  Sys.getenv("R_PLATFORM"), sep = "-"))))
                        makefiles <- c(makefiles, f)
                    else if (file.exists(f <- path.expand("~/.R/Makevars")))
                        makefiles <- c(makefiles, f)
                    res <- system(paste(MAKE,
                                        paste("-f", shQuote(makefiles), collapse = " ")))
                    if (res == 0) shlib_install(instdir, rarch)
                    else has_error <- TRUE
                    setwd(owd)
                } else { ## no src/Makefile
                    owd <- setwd("src")
                    srcs <- dir(pattern = "\\.([cfmM]|cc|cpp|f90|f95|mm)$",
                                all.files = TRUE)
                    ## This allows Makevars to set OBJECTS or its own targets.
                    allfiles <- if (file.exists("Makevars")) c("Makevars", srcs) else srcs
                    wd2 <- setwd(file.path(R.home("bin"), "exec"))
                    archs <- Sys.glob("*")
                    setwd(wd2)
                    if (length(allfiles)) {
                        ## if there is a configure script we install only the main
                        ## sub-architecture
                        if (!multiarch || length(archs) <= 1 ||
                            file_test("-x", "../configure")) {
                            if (nzchar(rarch))
                                starsmsg("***", "arch - ",
                                         substr(rarch, 2, 1000))
                            has_error <- run_shlib(pkg_name, srcs, instdir, rarch)
                        } else {
                            setwd(owd)
                            test_archs <- archs
                            for(arch in archs) {
                                if (arch == "R") {
                                    ## top-level, so one arch without subdirs
                                    has_error <- run_shlib(pkg_name, srcs, instdir, "")
                                } else {
                                    starsmsg("***", "arch - ", arch)
                                    ss <- paste("src", arch, sep = "-")
                                    dir.create(ss, showWarnings = FALSE)
                                    file.copy(Sys.glob("src/*"), ss, recursive = TRUE)
                                    setwd(ss)
                                    ra <- paste0("/", arch)
                                    ## FIXME: do this lower down
                                    Sys.setenv(R_ARCH = ra)
                                    has_error <- run_shlib(pkg_name, srcs, instdir, ra)
                                    Sys.setenv(R_ARCH = rarch)
                                    setwd(owd)
                                    if (has_error) break
                                }
                            }
                        }
                    } else warning("no source files found", call. = FALSE)
                }
                setwd(owd)
            }
            if (has_error)
                pkgerrmsg("compilation failed", pkg_name)

            ## if we have subarchs, update DESCRIPTION
            fi <- file.info(Sys.glob(file.path(instdir, "libs", "*")))
            dirs <- basename(row.names(fi[fi$isdir %in% TRUE, ]))
            ## avoid DLLs installed by rogue packages
            if(WINDOWS) dirs <- dirs[dirs %in% c("i386", "x64")]
            if (length(dirs)) {
                descfile <- file.path(instdir, "DESCRIPTION")
                olddesc <- readLines(descfile, warn = FALSE)
                olddesc <- grep("^Archs:", olddesc,
                                invert = TRUE, value = TRUE, useBytes = TRUE)
                newdesc <- c(olddesc,
                             paste("Archs:", paste(dirs, collapse = ", "))
                             )
                writeLines(newdesc, descfile, useBytes = TRUE)
            }
        } else if (multiarch) {   # end of src dir
            if (WINDOWS) {
                wd2 <- setwd(file.path(R.home(), "bin")) # not R.home("bin")
                archs <- Sys.glob("*")
                setwd(wd2)
                test_archs <- archs[archs %in% c("i386", "x64")]
            } else {
                wd2 <- setwd(file.path(R.home("bin"), "exec"))
                test_archs <- Sys.glob("*")
                setwd(wd2)
            }
        }
        if (WINDOWS && "x64" %in% test_archs) {
            ## we cannot actually test x64 unless this is 64-bit
            ## Windows, even if it is installed.
            if (!grepl(" x64 ", win.version())) test_archs <- "i386"
        }


        ## R files must start with a letter
	if (install_R && dir.exists("R") && length(dir("R"))) {
	    starsmsg(stars, "R")
	    dir.create(file.path(instdir, "R"), recursive = TRUE,
		       showWarnings = FALSE)
	    ## This cannot be done in a C locale
	    res <- try(.install_package_code_files(".", instdir))
	    if (inherits(res, "try-error"))
		pkgerrmsg("unable to collate and parse R files", pkg_name)

	    if (file.exists(f <- file.path("R", "sysdata.rda"))) {
                comp <- TRUE
                ## (We set .libPaths)
                if(!is.na(lazycompress <- desc["SysDataCompression"])) {
                    comp <- switch(lazycompress,
                                   "none" = FALSE,
                                   "gzip" = TRUE,
                                   "bzip2" = 2L,
                                   "xz" = 3L,
                                   TRUE)  # default to gzip
                } else if(file.info(f)$size > 1e6) comp <- 3L # "xz"
		res <- try(sysdata2LazyLoadDB(f, file.path(instdir, "R"),
                                              compress = comp))
		if (inherits(res, "try-error"))
		    pkgerrmsg("unable to build sysdata DB", pkg_name)
	    }
	    if (fake) {
		## Fix up hook functions so they do not attempt to
		## (un)load missing compiled code, initialize ...
		## This does stop them being tested at all.
		if (file.exists("NAMESPACE")) {
		    cat("",
			'.onLoad <- .onAttach <- function(lib, pkg) NULL',
			'.onUnload <- function(libpaths) NULL',
			sep = "\n",
			file = file.path(instdir, "R", pkg_name), append = TRUE)
		    ## <NOTE>
		    ## Tweak fake installation to provide an 'empty'
		    ## useDynLib() for the time being.  Completely
		    ## removing the directive results in checkFF()
		    ## being too aggresive in the case where the
		    ## presence of the directive enables unambiguous
		    ## symbol resolution w/out 'PACKAGE' arguments.
		    ## However, empty directives are not really meant
		    ## to work ...

		    ## encoding issues ... so need useBytes = TRUE
		    ## FIXME: some packages have useDynLib()
		    ## spread over several lines.
		    writeLines(sub("useDynLib.*", 'useDynLib("")',
				   readLines("NAMESPACE", warn = FALSE),
				   perl = TRUE, useBytes = TRUE),
			       file.path(instdir, "NAMESPACE"))
		    ## </NOTE>
		} else {
		    cat("",
                        '.onLoad <- function (libname, pkgname) NULL',
                        '.onAttach <- function (libname, pkgname) NULL',
			'.onDetach <- function(libpath) NULL',
			'.onUnload <- function(libpath) NULL',
			'.Last.lib <- function(libpath) NULL',
			sep = "\n",
			file = file.path(instdir, "R", pkg_name), append = TRUE)
		}
	    }
	}                           # end of R

        ## data files must not be hidden: data() may ignore them
	if (install_data && dir.exists("data") && length(dir("data"))) {
	    starsmsg(stars, "data")
	    files <- Sys.glob(file.path("data", "*")) # ignores dotfiles
	    if (length(files)) {
		is <- file.path(instdir, "data")
		dir.create(is, recursive = TRUE, showWarnings = FALSE)
		file.remove(Sys.glob(file.path(instdir, "data", "*")))
		file.copy(files, is, TRUE)
		thislazy <- parse_description_field(desc, "LazyData",
						    default = lazy_data)
		if (!thislazy && resave_data) {
		    paths <- Sys.glob(c(file.path(is, "*.rda"),
					file.path(is, "*.RData")))
		    if (pkg_name == "cyclones")
			paths <-
			    c(paths, Sys.glob(file.path(is, "*.Rdata")))
		    if (length(paths)) {
			starsmsg(paste0(stars, "*"), "resaving rda files")
			resaveRdaFiles(paths, compress = "auto")
		    }
		}
		Sys.chmod(Sys.glob(file.path(instdir, "data", "*")), fmode)
		if (thislazy) {
		    starsmsg(paste0(stars, "*"),
                             "moving datasets to lazyload DB")
		    ## 'it is possible that data in a package will
		    ## make use of the code in the package, so ensure
		    ## the package we have just installed is on the
		    ## library path.'
		    ## (We set .libPaths)
                    lazycompress <- desc["LazyDataCompression"]
                    if(!is.na(lazycompress))
                        data_compress <- switch(lazycompress,
                                                "none" = FALSE,
                                                "gzip" = TRUE,
                                                "bzip2" = 2L,
                                                "xz" = 3L,
                                                TRUE)  # default to gzip
		    res <- try(data2LazyLoadDB(pkg_name, lib,
					       compress = data_compress))
		    if (inherits(res, "try-error"))
			pkgerrmsg("lazydata failed", pkg_name)
		}
	    } else warning("empty 'data' directory", call. = FALSE)
        }

        ## demos must start with a letter
	if (install_demo && dir.exists("demo") && length(dir("demo"))) {
	    starsmsg(stars, "demo")
	    dir.create(file.path(instdir, "demo"), recursive = TRUE,
		       showWarnings = FALSE)
	    file.remove(Sys.glob(file.path(instdir, "demo", "*")))
	    res <- try(.install_package_demos(".", instdir))
	    if (inherits(res, "try-error"))
		pkgerrmsg("ERROR: installing demos failed")
	    Sys.chmod(Sys.glob(file.path(instdir, "demo", "*")), fmode)
	}

        ## dotnames are ignored.
	if (install_exec && dir.exists("exec") && length(dir("exec"))) {
	    starsmsg(stars, "exec")
	    dir.create(file.path(instdir, "exec"), recursive = TRUE,
		       showWarnings = FALSE)
	    file.remove(Sys.glob(file.path(instdir, "exec", "*")))
	    files <- Sys.glob(file.path("exec", "*"))
	    if (length(files)) {
		file.copy(files, file.path(instdir, "exec"), TRUE)
                if (!WINDOWS)
		    Sys.chmod(Sys.glob(file.path(instdir, "exec", "*")), dmode)
	    }
	}

	if (install_inst && dir.exists("inst") &&
            length(dir("inst", all.files = TRUE)) > 2L) {
	    starsmsg(stars, "inst")
            i_dirs <- list.dirs("inst")[-1L] # not inst itself
            i_dirs <- grep(.vc_dir_names_re, i_dirs,
                           invert = TRUE, value = TRUE)
            ## This ignores any restrictive permissions in the source
            ## tree, since the later .Call(dirchmod) call will
            ## fix the permissions.

            ## handle .Rinstignore:
            ignore_file <- ".Rinstignore"
            ignore <- if (file.exists(ignore_file)) {
                ignore <- readLines(ignore_file, warn = FALSE)
                ignore[nzchar(ignore)]
            } else character()
            for(e in ignore)
                i_dirs <- grep(e, i_dirs, perl = TRUE, invert = TRUE,
                               value = TRUE, ignore.case = TRUE)
            lapply(gsub("^inst", instdir, i_dirs),
                   function(p) dir.create(p, FALSE, TRUE)) # be paranoid
            i_files <- list.files("inst", all.files = TRUE,
                                  full.names = TRUE, recursive = TRUE)
            i_files <- grep(.vc_dir_names_re, i_files,
                            invert = TRUE, value = TRUE)
            for(e in ignore)
                i_files <- grep(e, i_files, perl = TRUE, invert = TRUE,
                                value = TRUE, ignore.case = TRUE)
            i_files <- i_files[!i_files %in%
                               c("inst/doc/Rplots.pdf", "inst/doc/Rplots.ps")]
            i_files <- grep("inst/doc/.*[.](log|aux|bbl|blg|dvi)$",
                            i_files, perl = TRUE, invert = TRUE,
                            value = TRUE, ignore.case = TRUE)
            ## Temporary kludge
            if (!dir.exists("vignettes") && ! pkgname %in% c("RCurl"))
                i_files <- grep("inst/doc/.*[.](png|jpg|jpeg|gif|ps|eps)$",
                                i_files, perl = TRUE, invert = TRUE,
                                value = TRUE, ignore.case = TRUE)
            i_files <- i_files[! i_files %in% "Makefile"]
            i2_files <- gsub("^inst", instdir, i_files)
            file.copy(i_files, i2_files)
            if (!WINDOWS) {
                ## make executable if the source file was (for owner)
                modes <- file.info(i_files)$mode
                execs <- as.logical(modes & as.octmode("100"))
		Sys.chmod(i2_files[execs], dmode)
            }
            if (compact_docs) {
                pdfs <- dir(file.path(instdir, "doc"), pattern="\\.pdf",
                            recursive = TRUE, full.names = TRUE,
                            all.files = TRUE)
                res <- compactPDF(pdfs, gs_quality = "none")
                ## print selectively
                print(res[res$old > 1e5, ])
            }
	}

	if (install_tests && dir.exists("tests") &&
            length(dir("tests", all.files = TRUE) > 2L)) {
	    starsmsg(stars, "tests")
	    file.copy("tests", instdir, recursive = TRUE)
	}

	## LazyLoading/Compiling
	if (install_R && dir.exists("R") && length(dir("R"))) {
            BC <- if (!is.na(byte_compile)) byte_compile
            else
                parse_description_field(desc, "ByteCompile", default = FALSE)
            rcp <- as.numeric(Sys.getenv("R_COMPILE_PKGS"))
            BC <- BC || (!is.na(rcp) && rcp > 0)
            if (BC) {
                starsmsg(stars,
                         "byte-compile and prepare package for lazy loading")
                ## need to disable JIT
                Sys.setenv(R_ENABLE_JIT = 0L)
                compiler::compilePKGS(1L)
                compiler::setCompilerOptions(suppressUndefined = TRUE)
            } else
                starsmsg(stars, "preparing package for lazy loading")
            keep.source <-
                parse_description_field(desc, "KeepSource",
                                        default = keep.source)
	    ## Something above, e.g. lazydata,  might have loaded the namespace
	    if (pkg_name %in% loadedNamespaces())
		unloadNamespace(pkg_name)
            deps_only <-
                config_val_to_logical(Sys.getenv("_R_CHECK_INSTALL_DEPENDS_", "FALSE"))
            if(deps_only) {
                env <- setRlibs(LinkingTo = TRUE)
                libs0 <- .libPaths()
		env <- sub("^.*=", "", env[1L])
                .libPaths(c(lib0, env))
            } else libs0 <- NULL
	    res <- try({
                suppressPackageStartupMessages(.getRequiredPackages(quietly = TRUE))
                makeLazyLoading(pkg_name, lib, keep.source = keep.source)
            })
            if (BC) compiler::compilePKGS(0L)
	    if (inherits(res, "try-error"))
		pkgerrmsg("lazy loading failed", pkg_name)
            if (!is.null(libs0)) .libPaths(libs0)
	}

	if (install_help) {
	    starsmsg(stars, "help")
	    if (!dir.exists("man") ||
	       !length(list_files_with_type("man", "docs")))
		cat("No man pages found in package ", sQuote(pkg_name), "\n")
	    encoding <- desc["Encoding"]
	    if (is.na(encoding)) encoding <- "unknown"
	    res <- try(.install_package_Rd_objects(".", instdir, encoding))
	    if (inherits(res, "try-error"))
		pkgerrmsg("installing Rd objects failed", pkg_name)


	    starsmsg(paste0(stars, "*"), "installing help indices")
	    ## always want HTML package index
	    .writePkgIndices(pkg_dir, instdir)
	    if (build_help) {
		## This is used as the default outputEncoding for latex
		outenc <- desc["Encoding"]
		if (is.na(outenc)) outenc <- "latin1" # or ASCII
		.convertRdfiles(pkg_dir, instdir,
				types = build_help_types,
				outenc = outenc)
	    }
	    if (file_test("-d", figdir <- file.path(pkg_dir, "man", "figures"))) {
		starsmsg(paste0(stars, "*"), "copying figures")
		dir.create(destdir <- file.path(instdir, "help", "figures"))
		file.copy(Sys.glob(c(file.path(figdir, "*.png"),
		                     file.path(figdir, "*.jpg"),
		                     file.path(figdir, "*.jpeg"),
				     file.path(figdir, "*.svg"),
				     file.path(figdir, "*.pdf"))), destdir)
	    }
        }

	## pkg indices: this also tangles the vignettes (if installed)
	if (install_inst || install_demo || install_help) {
	    starsmsg(stars, "building package indices")
	    res <- try(.install_package_indices(".", instdir))
	    if (inherits(res, "try-error"))
		errmsg("installing package indices failed")
            if(file_test("-d", "vignettes")) {
                starsmsg(stars, "installing vignettes")
                enc <- desc["Encoding"]
                if (is.na(enc)) enc <- ""
		if (!fake &&
                    file_test("-f", file.path("build", "vignette.rds")))
		    installer <- .install_package_vignettes3
		## FIXME:  this handles pre-3.0.2 tarballs.  In the long run, delete the alternative.
		else
		    installer <- .install_package_vignettes2
                res <- try(installer(".", instdir, enc))
	    if (inherits(res, "try-error"))
		errmsg("installing vignettes failed")
            }
	}

	## Install a dump of the parsed NAMESPACE file
        ## For a fake install, use the modified NAMESPACE file we installed
	if (install_R && file.exists("NAMESPACE")) {
	    res <- try(.install_package_namespace_info(if(fake) instdir else ".", instdir))
	    if (inherits(res, "try-error"))
		errmsg("installing namespace metadata failed")
	}

        if (clean) run_clean()

        if (test_load) {
            ## Do this in a separate R process, in case it crashes R.
	    starsmsg(stars, "testing if installed package can be loaded")
            ## FIXME: maybe the quoting as 'lib' is not quite good enough
            ## On a Unix-alike this calls system(input=)
            ## and that uses a temporary file and redirection.
            cmd <- paste0("tools:::.test_load_package('", pkg_name, "', '", lib, "')")
            ## R_LIBS was set already.  R_runR is in check.R
            deps_only <-
                config_val_to_logical(Sys.getenv("_R_CHECK_INSTALL_DEPENDS_", "FALSE"))
            env <- if (deps_only) setRlibs(lib0, self = TRUE, quote = TRUE) else ""
            if (length(test_archs) > 1L) {
                msgs <- character()
                opts <- "--no-save --slave"
                for (arch in test_archs) {
                    starsmsg("***", "arch - ", arch)
                    out <- R_runR(cmd, opts, env = env, arch = arch)
                    if(length(attr(out, "status")))
                        msgs <- c(msgs, arch)
                    if(length(out))
                        cat(paste(c(out, ""), collapse = "\n"))
                }
                if (length(msgs)) {
                    msg <- paste("loading failed for",
                                 paste(sQuote(msgs), collapse = ", "))
                    errmsg(msg) # does not return
                }
            } else {
                opts <- if (deps_only) "--vanilla --slave"
                else "--no-save --slave"
                out <- R_runR(cmd, opts, env = env)
                if(length(out))
                    cat(paste(c(out, ""), collapse = "\n"))
                if(length(attr(out, "status")))
                    errmsg("loading failed") # does not return
            }
        }
    }

    options(showErrorCalls=FALSE)
    pkgs <- character()
    if (is.null(args)) {
        args <- commandArgs(TRUE)
        ## it seems that splits on spaces, so try harder.
        args <- paste(args, collapse = " ")
        args <- strsplit(args,'nextArg', fixed = TRUE)[[1L]][-1L]
    }
    args0 <- args

    startdir <- getwd()
    if (is.null(startdir))
        stop("current working directory cannot be ascertained")
    lib <- lib0 <- ""
    clean <- FALSE
    preclean <- FALSE
    debug <- FALSE
    static_html <- nzchar(system.file("html", "mean.html", package="base"))
    build_html <- static_html
    build_latex <- FALSE
    build_example <- FALSE
    use_configure <- TRUE
    auto_zip <- FALSE
    configure_args <- character()
    configure_vars <- character()
    fake <- FALSE
    lazy <- TRUE
    lazy_data <- FALSE
    byte_compile <- NA # means take from DESCRIPTION file.
    ## Next is not very useful unless R CMD INSTALL reads a startup file
    lock <- getOption("install.lock", NA) # set for overall or per-package
    pkglock <- FALSE  # set for per-package locking
    libs_only <- FALSE
    tar_up <- zip_up <- FALSE
    shargs <- character()
    multiarch <- TRUE
    force_biarch <- FALSE
    force_both <- FALSE
    test_load <- TRUE
    merge <- FALSE
    dsym <- nzchar(Sys.getenv("PKG_MAKE_DSYM"))
    get_user_libPaths <- FALSE
    data_compress <- TRUE # FALSE (none), TRUE (gzip), 2 (bzip2), 3 (xz)
    resave_data <- FALSE
    compact_docs <- FALSE
    keep.source <- getOption("keep.source.pkgs")

    install_libs <- TRUE
    install_R <- TRUE
    install_data <- TRUE
    install_demo <- TRUE
    install_exec <- TRUE
    install_inst <- TRUE
    install_help <- TRUE
    install_tests <- FALSE

    while(length(args)) {
        a <- args[1L]
        if (a %in% c("-h", "--help")) {
            Usage()
            q("no", runLast = FALSE)
        }
        else if (a %in% c("-v", "--version")) {
            cat("R add-on package installer: ",
                R.version[["major"]], ".",  R.version[["minor"]],
                " (r", R.version[["svn rev"]], ")\n", sep = "")
            cat("",
                "Copyright (C) 2000-2013 The R Core Team.",
                "This is free software; see the GNU General Public License version 2",
                "or later for copying conditions.  There is NO warranty.",
                sep = "\n")
            q("no", runLast = FALSE)
        } else if (a %in% c("-c", "--clean")) {
            clean <- TRUE
            shargs <- c(shargs, "--clean")
        } else if (a == "--preclean") {
            preclean <- TRUE
            shargs <- c(shargs, "--preclean")
        } else if (a %in% c("-d", "--debug")) {
            debug <- TRUE
        } else if (a == "--no-configure") {
            use_configure <- FALSE
        } else if (a == "--no-docs") {
            build_html <- build_latex <- build_example <- FALSE
        } else if (a == "--no-html") {
            build_html <- FALSE
        } else if (a == "--html") {
            build_html <- TRUE
        } else if (a == "--latex") {
            build_latex <- TRUE
        } else if (a == "--example") {
            build_example <- TRUE
        } else if (a == "--use-zip-data") {
            warning("use of '--use-zip-data' is defunct",
                    call. = FALSE, domain = NA)
            warning("use of '--use-zip-data' is deprecated",
                    call. = FALSE, domain = NA)
        } else if (a == "--auto-zip") {
            warning("'--auto-zip' is defunct",
                           call. = FALSE, domain = NA)
        } else if (a == "-l") {
            if (length(args) >= 2L) {lib <- args[2L]; args <- args[-1L]}
            else stop("-l option without value", call. = FALSE)
        } else if (substr(a, 1, 10) == "--library=") {
            lib <- substr(a, 11, 1000)
        } else if (substr(a, 1, 17) == "--configure-args=") {
            configure_args <- c(configure_args, substr(a, 18, 1000))
        } else if (substr(a, 1, 17) == "--configure-vars=") {
            configure_vars <- c(configure_vars, substr(a, 18, 1000))
        } else if (a == "--fake") {
            fake <- TRUE
        } else if (a == "--no-lock") {
            lock <- pkglock <- FALSE
        } else if (a == "--lock") {
            lock <- TRUE; pkglock <- FALSE
        } else if (a == "--pkglock") {
            lock <- pkglock <- TRUE
        } else if (a == "--libs-only") {
            libs_only <- TRUE
        } else if (a == "--no-multiarch") {
            multiarch <- FALSE
        } else if (a == "--force-biarch") {
            force_biarch <- TRUE
        } else if (a == "--compile-both") {
            force_both <- TRUE
        } else if (a == "--maybe-get-user-libPaths") {
            get_user_libPaths <- TRUE
        } else if (a == "--build") {
            if (WINDOWS) zip_up <- TRUE else tar_up <- TRUE
        } else if (substr(a, 1, 16) == "--data-compress=") {
            dc <- substr(a, 17, 1000)
            dc <- match.arg(dc, c("none", "gzip", "bzip2", "xz"))
            data_compress <- switch(dc,
                                    "none" = FALSE,
                                    "gzip" = TRUE,
                                    "bzip2" = 2,
                                    "xz" = 3)
        } else if (a == "--resave-data") {
            resave_data <- TRUE
        } else if (a == "--install-tests") {
            install_tests <- TRUE
        } else if (a == "--no-inst") {
            install_inst <- FALSE
        } else if (a == "--no-R") {
            install_R <- FALSE
        } else if (a == "--no-libs") {
            install_libs <- FALSE
        } else if (a == "--no-data") {
            install_data <- FALSE
        } else if (a == "--no-demo") {
            install_demo <- FALSE
        } else if (a == "--no-exec") {
            install_exec <- FALSE
        } else if (a == "--no-help") {
            install_help <- FALSE
        } else if (a == "--no-test-load") {
            test_load <- FALSE
        } else if (a == "--no-clean-on-error") {
            clean_on_error  <- FALSE
        } else if (a == "--merge-multiarch") {
            merge <- TRUE
        } else if (a == "--compact-docs") {
            compact_docs <- TRUE
        } else if (a == "--with-keep.source") {
            keep.source <- TRUE
        } else if (a == "--without-keep.source") {
            keep.source <- FALSE
        } else if (a == "--byte-compile") {
            byte_compile <- TRUE
        } else if (a == "--no-byte-compile") {
            byte_compile <- FALSE
        } else if (a == "--dsym") {
            dsym <- TRUE
        } else if (substr(a, 1, 1) == "-") {
            message("Warning: unknown option ", sQuote(a), domain = NA)
        } else pkgs <- c(pkgs, a)
        args <- args[-1L]
    }

    tmpdir <- tempfile("R.INSTALL")
    if (!dir.create(tmpdir))
        stop("cannot create temporary directory")

    if (merge) {
        if (length(pkgs) != 1L || !file_test("-f", pkgs))
            stop("ERROR: '--merge-multiarch' applies only to a single tarball",
                 call. = FALSE)
        if (WINDOWS) {
            f  <- dir(file.path(R.home(), "bin"))
            archs <- f[f %in% c("i386", "x64")]
            if (length(archs) > 1L) {
                args <- args0[! args0 %in% c("--merge-multiarch", "--build")]
                ## this will report '* DONE (foo)' if it works, which
                ## R CMD check treats as an indication of success.
                ## so use a backdoor to suppress it.
                Sys.setenv("_R_INSTALL_NO_DONE_" = "yes")
                for (arch in archs) {
                    cmd <- c(file.path(R.home(), "bin", arch, "Rcmd.exe"),
                             "INSTALL", args, "--no-multiarch")
                    if (arch == "x64") {
                        cmd <- c(cmd, "--libs-only", if(zip_up) "--build")
                        Sys.unsetenv("_R_INSTALL_NO_DONE_")
                    }
                    cmd <- paste(cmd, collapse = " ")
                    if (debug) message("about to run ", cmd, domain = NA)
                    message("\n", "install for ", arch, "\n", domain = NA)
                    res <- system(cmd)
                    if(res) break
                }
            }
        } else {
            archs  <- dir(file.path(R.home("bin"), "exec"))
            if (length(archs) > 1L) {
                args <- args0[! args0 %in% c("--merge-multiarch", "--build")]
                ## this will report '* DONE (foo)' if it works, which
                ## R CMD check treats as an indication of success.
                ## so use a backdoor to suppress it.
                Sys.setenv("_R_INSTALL_NO_DONE_" = "yes")
                last <- archs[length(archs)]
                for (arch in archs) {
                    cmd <- c(file.path(R.home("bin"), "R"),
                             "--arch", arch, "CMD",
                             "INSTALL", args, "--no-multiarch")
                    if (arch != archs[1L]) cmd <- c(cmd, "--libs-only")
                    if (arch == last) {
                        Sys.unsetenv("_R_INSTALL_NO_DONE_")
                        if(tar_up) cmd <- c(cmd, "--build")
                    }
                    cmd <- paste(cmd, collapse = " ")
                    if (debug) message("about to run ", cmd, domain = NA)
                    message("\n", "install for ", arch, "\n", domain = NA)
                    res <- system(cmd)
                    if(res) break
                }
            }
        }
        if (length(archs) > 1L) {
            if (res) do_exit_on_error()
            do_cleanup()
            on.exit()
            return(invisible())
        }
        message("only one architecture so ignoring '--merge-multiarch'",
                domain = NA)
    }

    ## now unpack tarballs and do some basic checks
    allpkgs <- character()
    for(pkg in pkgs) {
        if (debug) message("processing ", sQuote(pkg), domain = NA)
        if (file_test("-f", pkg)) {
            if (WINDOWS && grepl("\\.zip$", pkg)) {
                if (debug) message("a zip file", domain = NA)
                pkgname <- basename(pkg)
                pkgname <- sub("\\.zip$", "", pkgname)
                pkgname <- sub("_[0-9.-]+$", "", pkgname)
                allpkgs <- c(allpkgs, pkg)
                next
            }
            if (debug) message("a file", domain = NA)
            of <- dir(tmpdir, full.names = TRUE)
            ## force the use of internal untar unless over-ridden
            ## so e.g. .tar.xz works everywhere
            if (utils::untar(pkg, exdir = tmpdir,
                             tar =  Sys.getenv("R_INSTALL_TAR", "internal")))
                errmsg("error unpacking tarball")
            ## Now see what we got
            nf <- dir(tmpdir, full.names = TRUE)
            new <- nf[!nf %in% of]
            if (!length(new))
                errmsg("cannot extract package from ", sQuote(pkg))
            if (length(new) > 1L)
                errmsg("extracted multiple files from ", sQuote(pkg))
            if (file.info(new)$isdir) pkgname <- basename(new)
            else errmsg("cannot extract package from ", sQuote(pkg))

            ## If we have a binary bundle distribution, there should
            ## be a DESCRIPTION file at top level. These are defunct
            if (file.exists(ff <- file.path(tmpdir, "DESCRIPTION"))) {
                con <- read.dcf(ff, "Contains")
                if (!is.na(con))
                    message("looks like a binary bundle", domain = NA)
                else
                    message("unknown package layout", domain = NA)
                do_cleanup_tmpdir()
                q("no", status = 1, runLast = FALSE)
            } else if (file.exists(file.path(tmpdir, pkgname, "DESCRIPTION"))) {
                allpkgs <- c(allpkgs, file.path(tmpdir, pkgname))
            } else errmsg("cannot extract package from ", sQuote(pkg))
        } else if (file.exists(file.path(pkg, "DESCRIPTION"))) {
            if (debug) message("a directory", domain = NA)
            pkgname <- basename(pkg)
            allpkgs <- c(allpkgs, fullpath(pkg))
        } else {
            warning("invalid package ", sQuote(pkg), call. = FALSE)
            next
        }
    }

    if (!length(allpkgs))
        stop("ERROR: no packages specified", call.=FALSE)


    if (!nzchar(lib)) {
        lib <- if (get_user_libPaths) { ## need .libPaths()[1L] *after* the site- and user-initialization
	    system(paste(file.path(R.home("bin"), "Rscript"),
                         "-e 'cat(.libPaths()[1L])'"),
                   intern = TRUE)
        }
        else .libPaths()[1L]
        starsmsg(stars, "installing to library ", sQuote(lib))
    } else {
        lib0 <- lib <- path.expand(lib)
        ## lib is allowed to be a relative path.
        ## should be OK below, but be sure.
        cwd <- tryCatch(setwd(lib), error = function(e)
                        stop(gettextf("ERROR: cannot cd to directory %s", sQuote(lib)),
                             call. = FALSE, domain = NA))
        lib <- getwd()
        setwd(cwd)
    }
    ok <- dir.exists(lib)
    if (ok) {
        if (WINDOWS) {
            ## file.access is unreliable on Windows
            ## the only known reliable way is to try it
            fn <- file.path(lib, paste("_test_dir", Sys.getpid(), sep = "_"))
            unlink(fn, recursive = TRUE) # precaution
            res <- try(dir.create(fn, showWarnings = FALSE))
            if (inherits(res, "try-error") || !res) ok <- FALSE
            else unlink(fn, recursive = TRUE)
        } else ok <- file.access(lib, 2L) == 0
    }
    if (!ok)
        stop("ERROR: no permission to install to directory ",
             sQuote(lib), call. = FALSE)

    group.writable <- if(WINDOWS) FALSE else {
	## install package group-writable  iff  in group-writable lib
        d <-  as.octmode("020")
	(file.info(lib)$mode & d) == d ## TRUE  iff  g-bit is "w"
    }

    if (libs_only) {
	install_R <- FALSE
	install_data <- FALSE
	install_demo <- FALSE
	install_exec <- FALSE
	install_inst <- FALSE
	install_help <- FALSE
    }
    more_than_libs <- !libs_only
    ## if(!WINDOWS && !more_than_libs) test_load <- FALSE


    mk_lockdir <- function(lockdir)
    {
        if (file.exists(lockdir)) {
            message("ERROR: failed to lock directory ", sQuote(lib),
                    " for modifying\nTry removing ", sQuote(lockdir),
                    domain = NA)
            do_cleanup_tmpdir()
            q("no", status = 3, runLast = FALSE)
        }
        dir.create(lockdir, recursive = TRUE)
        if (!dir.exists(lockdir)) {
            message("ERROR: failed to create lock directory ", sQuote(lockdir),
                    domain = NA)
            do_cleanup_tmpdir()
            q("no", status = 3, runLast = FALSE)
        }
        if (debug) starsmsg(stars, "created lock directory ", sQuote(lockdir))
    }

    if (is.na(lock)) {
        lock <- TRUE
        pkglock <- length(allpkgs) == 1L
    }
    if (lock && !pkglock) {
        lockdir <- file.path(lib, "00LOCK")
        mk_lockdir(lockdir)
    }

    if  ((tar_up || zip_up) && fake)
        stop("building a fake installation is disallowed")

    if (fake) {
        use_configure <- FALSE
        build_html <- FALSE
        build_latex <- FALSE
        build_example <- FALSE
	install_libs <- FALSE
	install_demo <- FALSE
	install_exec <- FALSE
#	install_inst <- FALSE
    }

    build_help_types <- character()
    if (build_html) build_help_types <- c(build_help_types, "html")
    if (build_latex) build_help_types <- c(build_help_types, "latex")
    if (build_example) build_help_types <- c(build_help_types, "example")
    build_help <- length(build_help_types) > 0L

    if (debug)
        starsmsg(stars, "build_help_types=",
                 paste(build_help_types, collapse = " "))

    if (debug)
        starsmsg(stars, "DBG: 'R CMD INSTALL' now doing do_install()")

    for(pkg in allpkgs) {
        if (pkglock) {
            lockdir <- file.path(lib, paste("00LOCK", basename(pkg), sep = "-"))
            mk_lockdir(lockdir)
        }
        do_install(pkg)
    }
    do_cleanup()
    on.exit()
    invisible()
} ## .install_packages()

## for R CMD SHLIB on all platforms
.SHLIB <- function()
{
    status <- .shlib_internal(commandArgs(TRUE))
    q("no", status = (status != 0), runLast=FALSE)
}

## for .SHLIB and R CMD INSTALL on all platforms
.shlib_internal <- function(args)
{
    Usage <- function()
        cat("Usage: R CMD SHLIB [options] files | linker options",
            "",
            "Build a shared object for dynamic loading from the specified source or",
            "object files (which are automagically made from their sources) or",
            "linker options.  If not given via '--output', the name for the shared",
            "object is determined from the first source or object file.",
            "",
            "Options:",
            "  -h, --help		print short help message and exit",
            "  -v, --version		print version info and exit",
            "  -o, --output=LIB	use LIB as (full) name for the built library",
            "  -c, --clean		remove files created during compilation",
            "  --preclean		remove files created during a previous run",
            "  -n, --dry-run		dry run, showing commands that would be used",
            "",
            "Windows only:",
            "  -d, --debug		build a debug DLL",
            "",
            "Report bugs at bugs@r-project.org .",
            sep = "\n")

    ## FIXME shQuote here?
    p1 <- function(...) paste(..., collapse = " ")

    WINDOWS <- .Platform$OS.type == "windows"
    if (!WINDOWS) {
        mconf <- readLines(file.path(R.home(),
                                     paste0("etc", Sys.getenv("R_ARCH")),
                                     "Makeconf"))
        SHLIB_EXT <- sub(".*= ", "", grep("^SHLIB_EXT", mconf, value = TRUE,
                                          perl = TRUE))
        SHLIB_LIBADD <- sub(".*= ", "", grep("^SHLIB_LIBADD", mconf,
                                             value = TRUE, perl = TRUE))
        MAKE <- Sys.getenv("MAKE")
        rarch <- Sys.getenv("R_ARCH")
    } else {
        rhome <- chartr("\\", "/", R.home())
        Sys.setenv(R_HOME = rhome)
        SHLIB_EXT <- ".dll"
        SHLIB_LIBADD <- ""
        MAKE <- "make"
        ## Formerly for winshlib.mk to pick up Makeconf
        rarch <- Sys.getenv("R_ARCH", NA)
        if(is.na(rarch)) {
            if (nzchar(.Platform$r_arch)) {
                rarch <- paste0("/", .Platform$r_arch)
                Sys.setenv(R_ARCH = rarch)
            } else rarch <- ""
        }
    }

    OBJ_EXT <- ".o" # all currrent compilers, but not some on Windows

    objs <- character()
    shlib <- ""
    site <- Sys.getenv("R_MAKEVARS_SITE", NA)
    if (is.na(site))
        site <- file.path(paste0(R.home("etc"), rarch), "Makevars.site")
    makefiles <-
        c(file.path(paste0(R.home("etc"), rarch), "Makeconf"),
          if(file.exists(site)) site,
          file.path(R.home("share"), "make",
                    if (WINDOWS) "winshlib.mk" else "shlib.mk"))
    shlib_libadd <- if (nzchar(SHLIB_LIBADD)) SHLIB_LIBADD else character()
    with_cxx <- FALSE
    with_f77 <- FALSE
    with_f9x <- FALSE
    with_objc <- FALSE
    use_cxx1x <- FALSE
    pkg_libs <- character()
    clean <- FALSE
    preclean <- FALSE
    dry_run <- FALSE
    debug <- FALSE

    while(length(args)) {
        a <- args[1L]
        if (a %in% c("-h", "--help")) {
            Usage()
            return(0L)
        }
        else if (a %in% c("-v", "--version")) {
            cat("R shared object builder: ",
                R.version[["major"]], ".",  R.version[["minor"]],
                " (r", R.version[["svn rev"]], ")\n", sep = "")
            cat("",
                "Copyright (C) 2000-2013 The R Core Team.",
                "This is free software; see the GNU General Public License version 2",
                "or later for copying conditions.  There is NO warranty.",
                sep = "\n")
            return(0L)
        } else if (a %in% c("-n", "--dry-run")) {
            dry_run <- TRUE
        } else if (a %in% c("-d", "--debug")) {
            debug <- TRUE
        } else if (a %in% c("-c", "--clean")) {
            clean <- TRUE
        } else if (a == "--preclean") {
            preclean <- TRUE
        } else if (a == "-o") {
            if (length(args) >= 2L) {shlib <- args[2L]; args <- args[-1L]}
            else stop("-o option without value", call. = FALSE)
        } else if (substr(a, 1, 9) == "--output=") {
            shlib <- substr(a, 10, 1000)
        } else {
            ## a source file or something like -Ldir -lfoo
            base <- sub("\\.[[:alnum:]]*$", "", a)
            ext <- sub(paste0(base, "."),  "", a, fixed = TRUE)
            nobj <- ""
            if (nzchar(ext)) {
                if (ext %in% c("cc", "cpp")) {
                    with_cxx <- TRUE
                    nobj <- base
                } else if (ext == "m") {
                    with_objc <- TRUE
                    nobj <- base
                } else if (ext %in% c("mm", "M")) {
                    ## ObjC++ implies ObjC because we need ObjC runtime
                    ## ObjC++ implies C++ because we use C++ linker
                    with_objc <- with_cxx <- TRUE
                    nobj <- base
                } else if (ext == "f") {
                    with_f77 <- TRUE
                    nobj <- base
                } else if (ext %in% c("f90", "f95")) {
                    with_f9x <- TRUE
                    nobj <- base
                } else if (ext == "c") {
                    nobj <- base
                } else if (ext == "o") {
                    nobj <- base
                }
                if (nzchar(nobj) && !nzchar(shlib))
                    shlib <- paste0(nobj, SHLIB_EXT)
            }
            if (nzchar(nobj)) objs <- c(objs, nobj)
            else pkg_libs <- c(pkg_libs, a)
        }
        args <- args[-1L]
    }

    if (length(objs)) objs <- paste0(objs, OBJ_EXT, collapse = " ")

    if (WINDOWS) {
        if (!is.na(f <- Sys.getenv("R_MAKEVARS_USER", NA))) {
            if (file.exists(f))  makefiles <- c(makefiles, f)
        } else if (rarch == "/x64" &&
                   file.exists(f <- path.expand("~/.R/Makevars.win64")))
            makefiles <- c(makefiles, f)
        else if (file.exists(f <- path.expand("~/.R/Makevars.win")))
            makefiles <- c(makefiles, f)
        else if (file.exists(f <- path.expand("~/.R/Makevars")))
            makefiles <- c(makefiles, f)
    } else {
        if (!is.na(f <- Sys.getenv("R_MAKEVARS_USER", NA))) {
            if (file.exists(f))  makefiles <- c(makefiles, f)
        } else if (file.exists(f <- path.expand(paste("~/.R/Makevars",
                                               Sys.getenv("R_PLATFORM"),
                                               sep = "-"))))
            makefiles <- c(makefiles, f)
        else if (file.exists(f <- path.expand("~/.R/Makevars")))
            makefiles <- c(makefiles, f)
    }

    makeobjs <- paste0("OBJECTS=", shQuote(objs))
    if (WINDOWS && file.exists("Makevars.win")) {
        makefiles <- c("Makevars.win", makefiles)
        lines <- readLines("Makevars.win", warn = FALSE)
        if (length(grep("^OBJECTS *=", lines, perl=TRUE, useBytes = TRUE)))
            makeobjs <- ""
        if (length(ll <- grep("^CXX_STD *=", lines, perl = TRUE,
                              value = TRUE, useBytes = TRUE))) {
            cxxstd <- gsub("^CXX_STD *=", "", ll)
            cxxstd <- gsub(" *", "", cxxstd)
            if (cxxstd == "CXX11") {
                use_cxx1x <- TRUE
            }
        }
    } else if (file.exists("Makevars")) {
        makefiles <- c("Makevars", makefiles)
        lines <- readLines("Makevars", warn = FALSE)
        if (length(grep("^OBJECTS *=", lines, perl = TRUE, useBytes = TRUE)))
            makeobjs <- ""
        if (length(ll <- grep("^CXX_STD *=", lines, perl = TRUE,
                              value = TRUE, useBytes = TRUE))) {
            cxxstd <- gsub("^CXX_STD *=", "", ll)
            cxxstd <- gsub(" *", "", cxxstd)
            if (cxxstd == "CXX11") {
                use_cxx1x <- TRUE
            }
        }
    }
    if (!use_cxx1x) {
        val <- Sys.getenv("USE_CXX1X", NA)
        if(!is.na(val)) {
            use_cxx1x <- TRUE
        }
        else {
            val <- Sys.getenv("R_PKG_CXX_STD")
            if (val == "CXX11") {
                use_cxx1x <- TRUE
            }
        }
    }

    makeargs <- paste0("SHLIB=", shQuote(shlib))
    if (with_f9x) {
        makeargs <- c("SHLIB_LDFLAGS='$(SHLIB_FCLDFLAGS)'",
                      "SHLIB_LD='$(SHLIB_FCLD)'", makeargs)
    } else if (with_cxx) {
        makeargs <- if (use_cxx1x)
            c("CXX='$(CXX1X) $(CXX1XSTD)'",
              "CXXFLAGS='$(CXX1XFLAGS)'",
              "CXXPICFLAGS='$(CXX1XPICFLAGS)'",
              "SHLIB_LDFLAGS='$(SHLIB_CXX1XLDFLAGS)'",
              "SHLIB_LD='$(SHLIB_CXX1XLD)'", makeargs)
        else
            c("SHLIB_LDFLAGS='$(SHLIB_CXXLDFLAGS)'",
              "SHLIB_LD='$(SHLIB_CXXLD)'", makeargs)
    }
    if (with_objc) shlib_libadd <- c(shlib_libadd, "$(OBJC_LIBS)")
    if (with_f77) shlib_libadd <- c(shlib_libadd, "$(FLIBS)")
    if (with_f9x) shlib_libadd <- c(shlib_libadd, "$(FCLIBS)")

    if (length(pkg_libs))
        makeargs <- c(makeargs,
                      paste0("PKG_LIBS='", p1(pkg_libs), "'"))
    if (length(shlib_libadd))
        makeargs <- c(makeargs,
                      paste0("SHLIB_LIBADD='", p1(shlib_libadd), "'"))

    if (WINDOWS && debug) makeargs <- c(makeargs, "DEBUG=T")
    ## TCLBIN is needed for tkrplot and tcltk2
    if (WINDOWS && rarch == "/x64") makeargs <- c(makeargs, "WIN=64 TCLBIN=64")

    build_objects_symbol_tables <-
        config_val_to_logical(Sys.getenv("_R_SHLIB_BUILD_OBJECTS_SYMBOL_TABLES_",
                                         "FALSE"))

    cmd <- paste(MAKE, p1(paste("-f", shQuote(makefiles))), p1(makeargs),
                 p1(makeobjs))
    if (dry_run) {
        cat("make cmd is\n  ", cmd, "\n\nmake would use\n", sep = "")
        system(paste(cmd, "-n"))
        res <- 0
    } else {
        if (preclean) system(paste(cmd, "shlib-clean"))
        res <- system(cmd)
        if(build_objects_symbol_tables) {
            ## Should only do this if the previous one went ok.
            system(paste(cmd, "symbols.rds"))
        }
        if (clean) system(paste(cmd, "shlib-clean"))
    }
    res # probably a multiple of 256
}


## called for base packages from src/Makefile[.win] and from
## .install.packages in this file.  Really *help* indices.
.writePkgIndices <-
    function(dir, outDir, OS = .Platform$OS.type, html = TRUE)
{
    re <- function(x)
    {
        ## sort order for topics, a little tricky
        ## FALSE sorts before TRUE
        xx <- rep(TRUE, length(x))
        xx[grep("-package", x, fixed = TRUE)] <- FALSE
        order(xx, toupper(x), x)
    }

    html_header <- function(pkg, title, version, conn)
    {
        cat(paste(HTMLheader(title, Rhome="../../..",
                             up="../../../doc/html/packages.html",
                             css = "R.css"),
                  collapse = "\n"),
           '<h2>Documentation for package &lsquo;', pkg, '&rsquo; version ',
            version, '</h2>\n\n', sep = "", file = conn)

	cat('<ul><li><a href="../DESCRIPTION">DESCRIPTION file</a>.</li>\n', file=conn)
	if (file.exists(file.path(outDir, "doc")))
	    cat('<li><a href="../doc/index.html">User guides, package vignettes and other documentation.</a></li>\n', file=conn)
	if (file.exists(file.path(outDir, "demo")))
	    cat('<li><a href="../demo">Code demos</a>.  Use <a href="../../utils/help/demo">demo()</a> to run them.</li>\n',
		 sep = "", file=conn)
	if (any(file.exists(c(file.path(outDir, "NEWS"), file.path(outDir, "NEWS.Rd")))))
	    cat('<li><a href="../NEWS">Package NEWS</a>.</li>\n',
		 sep = "", file=conn)

        cat('</ul>\n\n<h2>Help Pages</h2>\n\n\n',
            sep ="", file = conn)
    }

    firstLetterCategory <- function(x)
    {
        x[grep("-package$", x)] <- " "
        x <- toupper(substr(x, 1, 1))
        x[x > "Z"] <- "misc"
        x[x < "A" & x != " "] <- "misc"
        x
    }

    ## This may well already have been done:
    Rd <- if (file.exists(f <- file.path(outDir, "Meta", "Rd.rds")))
        readRDS(f)
    else {
        ## Keep this in sync with .install_package_Rd_indices().
        ## Rd objects should already have been installed.
        db <- tryCatch(Rd_db(basename(outDir), lib.loc = dirname(outDir)),
                       error = function(e) NULL)
        ## If not, we build the Rd db from the sources:
        if (is.null(db)) db <- Rd_db(dir = dir)
        Rd <- Rd_contents(db)
        saveRDS(Rd, file.path(outDir, "Meta", "Rd.rds"))
        Rd
    }

    topics <- Rd$Aliases
    M <- if (!length(topics)) {
        data.frame(Topic = character(),
                   File = character(),
                   Title = character(),
                   Internal = character(),
                   stringsAsFactors = FALSE)
    } else {
        lens <- sapply(topics, length)
        files <- sub("\\.[Rr]d$", "", Rd$File)
        internal <- sapply(Rd$Keywords, function(x) "internal" %in% x)
        data.frame(Topic = unlist(topics),
                   File = rep.int(files, lens),
                   Title = rep.int(Rd$Title, lens),
                   Internal = rep.int(internal, lens),
                   stringsAsFactors = FALSE)
    }
    ## FIXME duplicated aliases warning
    outman <- file.path(outDir, "help")
    dir.create(outman, showWarnings = FALSE)
    MM <- M[re(M[, 1L]), 1:2]
    write.table(MM, file.path(outman, "AnIndex"),
                quote = FALSE, row.names = FALSE, col.names = FALSE, sep = "\t")
    a <- structure(MM[, 2L], names=MM[, 1L])
    saveRDS(a, file.path(outman, "aliases.rds"))

    ## have HTML index even if no help pages
    outman <- file.path(outDir, "html")
    dir.create(outman, showWarnings = FALSE)
    outcon <- file(file.path(outman, "00Index.html"), "wt")
    on.exit(close(outcon))
    ## we know we have a valid file by now.
    desc <- read.dcf(file.path(outDir, "DESCRIPTION"))[1L, ]
    ## re-encode if necessary
    if(!is.na(enc <- desc["Encoding"])) {
        ## should be valid in UTF-8, might be invalid in declared encoding
        desc <- iconv(desc, enc, "UTF-8", sub = "byte")
    }
    ## drop internal entries
    M <- M[!M[, 4L], ]
    if (desc["Package"] %in% c("base", "graphics", "stats", "utils")) {
        for(pass in 1:2) {
            ## we skip method aliases
            gen <- gsub("\\.data\\.frame", ".data_frame", M$Topic)
            gen <- sub("\\.model\\.matrix$", ".modelmatrix", gen)
            gen <- sub("^(all|as|is|file|Sys|row|na|model)\\.", "\\1_", gen)
            gen <- sub("^(.*)\\.test", "\\1_test", gen)
            gen <- sub("([-[:alnum:]]+)\\.[^.]+$", "\\1", gen)
            last <- nrow(M)
            nongen <- gen %in% c("ar", "bw", "contr", "dyn", "lm", "qr", "ts", "which", ".Call", ".External", ".Library", ".First", ".Last")
            nc <- nchar(gen)
            asg <- (nc > 3) & substr(gen, nc-1, nc) == "<-"
            skip <- (gen == c("", gen[-last])) & (M$File == c("", M$File[-last])) & !nongen
            skip <- skip | asg
            ##N <- cbind(M$Topic, gen, c("", gen[-last]), skip)
            M <- M[!skip, ]
        }
    }

    # Collapse method links into unique (generic, file) pairs
    M$Topic <- sub("^([^,]*),.*-method$", "\\1-method", M$Topic)
    M <- M[!duplicated(M[, c("Topic", "File")]),]
    M <- M[re(M[, 1L]), ]

    ## encode some entries.
    htmlize <- function(x, backtick)
    {
        x <- gsub("&", "&amp;", x, fixed = TRUE)
        x <- gsub("<", "&lt;", x, fixed = TRUE)
        x <- gsub(">", "&gt;", x, fixed = TRUE)
        if (backtick) {
            x <- gsub("---", "-", x, fixed = TRUE)
            x <- gsub("--", "-", x, fixed = TRUE)
            ## these have been changed in the Rd parser
            #x <- gsub("``", "&ldquo;", x, fixed = TRUE)
            #x <- gsub("''", "&rdquo;", x, fixed = TRUE)
            #x <- gsub("\\`([^']+)'", "&lsquo;\\1&rsquo;", x)
            #x <- gsub("`", "'", x, fixed = TRUE)
        }
        x
    }
    M$HTopic <- htmlize(M$Topic, FALSE)
    M$Title <- htmlize(M$Title, TRUE)

    ## No need to handle encodings: everything is in UTF-8

    html_header(desc["Package"], desc["Title"], desc["Version"], outcon)

    use_alpha <- (nrow(M) > 100)
    if (use_alpha) {
        first <- firstLetterCategory(M$Topic)
        nm <- sort(names(table(first)))
        m <- match(" ", nm, 0L) # -package
        if (m) nm <- c(" ", nm[-m])
        m <- match("misc", nm, 0L) # force last in all locales.
        if (m) nm <- c(nm[-m], "misc")
	writeLines(c("<p align=\"center\">",
		     paste0("<a href=\"#", nm, "\">", nm, "</a>"),
		     "</p>\n"), outcon)
        for (f in nm) {
            MM <- M[first == f, ]
            if (f != " ")
                cat("\n<h2><a name=\"", f, "\">-- ", f, " --</a></h2>\n\n",
                    sep = "", file = outcon)
	    writeLines(c('<table width="100%">',
			 paste0('<tr><td width="25%"><a href="', MM[, 2L], '.html">',
				MM$HTopic, '</a></td>\n<td>', MM[, 3L],'</td></tr>'),
			 "</table>"), outcon)
       }
    } else if (nrow(M)) {
	writeLines(c('<table width="100%">',
		     paste0('<tr><td width="25%"><a href="', M[, 2L], '.html">',
			    M$HTopic, '</a></td>\n<td>', M[, 3L],'</td></tr>'),
		     "</table>"), outcon)
    } else { # no rows
         writeLines("There are no help pages in this package", outcon)
    }
    writeLines('</body></html>', outcon)
    file.copy(file.path(R.home("doc"), "html", "R.css"), outman)
    invisible(NULL)
}

### * .convertRdfiles

## possible types are "html", "latex", "example"
## outenc is used as the default output encoding for latex conversion
.convertRdfiles <-
    function(dir, outDir, types = "html", silent = FALSE, outenc = "UTF-8")
{
    showtype <- function(type) {
    	if (!shown) {
            nc <- nchar(bf)
            if (nc < 38L)
                cat("    ", bf, rep(" ", 40L - nc), sep = "")
            else
                cat("    ", bf, "\n", rep(" ", 44L), sep = "")
            shown <<- TRUE
        }
        ## 'example' is always last, so 5+space
        cat(type, rep(" ", max(0L, 6L - nchar(type))), sep = "")
    }

    dirname <- c("html", "latex", "R-ex")
    ext     <- c(".html", ".tex", ".R")
    names(dirname) <- names(ext) <- c("html", "latex", "example")
    mandir <- file.path(dir, "man")
    if (!file_test("-d", mandir)) return()
    desc <- readRDS(file.path(outDir, "Meta", "package.rds"))$DESCRIPTION
    pkg <- desc["Package"]
    ver <- desc["Version"]

    for(type in types)
        dir.create(file.path(outDir, dirname[type]), showWarnings = FALSE)

    cat("  converting help for package ", sQuote(pkg), "\n", sep = "")

    ## FIXME: add this lib to lib.loc?
    if ("html" %in% types) {
        ## may be slow, so add a message
        if (!silent) message("    finding HTML links ...", appendLF = FALSE, domain = NA)
        Links <- findHTMLlinks(outDir, level = 0:1)
        if (!silent) message(" done")
        .Links2 <- function() {
            message("\n    finding level-2 HTML links ...", appendLF = FALSE, domain = NA)
            Links2 <- findHTMLlinks(level = 2)
            message(" done", domain = NA)
            Links2
        }
        delayedAssign("Links2", .Links2())
    }

    ## Rd objects may already have been installed.
    db <- tryCatch(Rd_db(basename(outDir), lib.loc = dirname(outDir)),
                   error = function(e) NULL)
    ## If not, we build the Rd db from the sources:
    if (is.null(db)) db <- Rd_db(dir = dir)
    if (!length(db)) return()

    .whandler <-  function(e) {
        .messages <<- c(.messages,
                        paste("Rd warning:", conditionMessage(e)))
        invokeRestart("muffleWarning")
    }
    .ehandler <- function(e) {
        message("", domain = NA) # force newline
        unlink(ff)
        stop(conditionMessage(e), domain = NA, call. = FALSE)
    }
    .convert <- function(expr)
        withCallingHandlers(tryCatch(expr, error = .ehandler),
                            warning = .whandler)

    files <- names(db) # not full file names
    for(nf in files) {
        .messages <- character()
        Rd <- db[[nf]]
        attr(Rd, "source") <- NULL
	bf <- sub("\\.[Rr]d$", "", basename(nf)) # e.g. nf = "unix/Signals.Rd"
	f <- attr(Rd, "Rdfile")# full file name

        shown <- FALSE

        if ("html" %in% types) {
            type <- "html"
            ff <- file.path(outDir, dirname[type],
                            paste0(bf, ext[type]))
            if (!file_test("-f", ff) || file_test("-nt", f, ff)) {
                showtype(type)
                ## assume prepare_Rd was run when dumping the .rds
                ## so use defines = NULL for speed
                .convert(Rd2HTML(Rd, ff, package = c(pkg, ver),
                                 defines = NULL,
                                 Links = Links, Links2 = Links2))
            }
        }
        if ("latex" %in% types) {
            type <- "latex"
            ff <- file.path(outDir, dirname[type],
                            paste0(bf, ext[type]))
            if (!file_test("-f", ff) || file_test("-nt", f, ff)) {
                showtype(type)
                .convert(Rd2latex(Rd, ff, defines = NULL,
                                  outputEncoding = outenc))
            }
        }
        if ("example" %in% types) {
            type <- "example"
            ff <- file.path(outDir, dirname[type],
                            paste0(bf, ext[type]))
            if (!file_test("-f", ff) || file_test("-nt", f, ff)) {
                .convert(Rd2ex(Rd, ff, defines = NULL))
                if (file_test("-f", ff)) showtype(type)
            }
        }
        if (shown) {
            cat("\n")
            if (length(.messages)) writeLines(unique(.messages))
        }
    }

    ## Now check for files to remove.
    ## These start with a letter.
    bfs <- sub("\\.[Rr]d$", "", basename(files)) # those to keep
    if ("html" %in% types) {
        type <- "html"
        have <- list.files(file.path(outDir, dirname[type]))
        have2 <- sub("\\.html", "", basename(have))
        drop <- have[! have2 %in% c(bfs, "00Index", "R.css")]
        unlink(file.path(outDir, dirname[type], drop))
    }
    if ("latex" %in% types) {
        type <- "latex"
        have <- list.files(file.path(outDir, dirname[type]))
        have2 <- sub("\\.tex", "", basename(have))
        drop <- have[! have2 %in% bfs]
        unlink(file.path(outDir, dirname[type], drop))
    }
    if ("example" %in% types) {
        type <- "example"
        have <- list.files(file.path(outDir, dirname[type]))
        have2 <- sub("\\.R", "", basename(have))
        drop <- have[! have2 %in% bfs]
        unlink(file.path(outDir, dirname[type], drop))
    }

}

### * .makeDllRes

.makeDllRes <-
function(name="", version = "0.0")
{
    if (file.exists(f <- "../DESCRIPTION") ||
        file.exists(f <- "../../DESCRIPTION")) {
        desc <- read.dcf(f)[[1L]]
        if (!is.na(f <- desc["Package"])) name <- f
        if (!is.na(f <- desc["Version"])) version <- f
    }
    writeLines(c('#include <windows.h>',
                 '#include "Rversion.h"',
                 '',
                 'VS_VERSION_INFO VERSIONINFO',
                 'FILEVERSION R_FILEVERSION',
                 'PRODUCTVERSION 3,0,0,0',
                 'FILEFLAGSMASK 0x3L',
                 'FILEOS VOS__WINDOWS32',
                 'FILETYPE VFT_APP',
                 'BEGIN',
                 '    BLOCK "StringFileInfo"',
                 '    BEGIN',
                 '        BLOCK "040904E4"',
                 '        BEGIN'))
    cat("            VALUE \"FileDescription\", \"DLL for R package `", name,"'\\0\"\n",
        "            VALUE \"FileVersion\", \"", version, "\\0\"\n", sep = "")
    writeLines(c(
                 '            VALUE "Compiled under R Version", R_MAJOR "." R_MINOR " (" R_YEAR "-" R_MONTH "-" R_DAY ")\\0"',
                 '            VALUE "Project info", "http://www.r-project.org\\0"',
                 '        END',
                 '    END',
                 '    BLOCK "VarFileInfo"',
                 '    BEGIN',
                 '        VALUE "Translation", 0x409, 1252',
                 '    END',
                 'END'))
}


### Local variables: ***
### mode: outline-minor ***
### outline-regexp: "### [*]+" ***
### End: ***
#  File src/library/tools/R/license.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/

## <NOTE>
## We want *standardized* license specs so that we can compute on them.
## In particular, we want to know whether licenses are recognizable as
## FOSS (http://en.wikipedia.org/wiki/Free_and_open-source_software)
## licenses.
##
## A license spec is standardized ("canonical") if it is an alternative
## of component specs which are one of the following:
##
## A. "Unlimited"
## B. "file LICENSE" or "file LICENCE"
## C. A specification based on the R license db
##    * A standard short specification (SSS field)
##    * The name or abbreviation of an unversioned license
##    * The name of abbreviation of a versioned license, optionally
##      followed by a version spec
##    * The name of a versioned license followed by the version
##    * The abbrevation of a versioned license combined with '-',
##   optionally followed by an extension spec as in B (in principle,
##   only if the base license is extensible).
##
## A license spec is standardizable if we know to transform it to
## standardized form.
##
## Note that the R license db also contains non-FOSS licenses, and hence
## information (FOSS field) on the FOSS status of the licenses.
## Ideally, a license taken as FOSS would be approved as free by the FSF
## and as open by the OSI: we also take licenses as FOSS when approved
## by the FSF (and not rejected by the OSI).
##
## See
##   http://www.gnu.org/licenses/license-list.html
##   http://opensource.org/licenses/alphabetical
## fot the FSF and OSI license lists, and also
##   http://www.fsf.org/licensing/licenses
##   http://en.wikipedia.org/wiki/List_of_FSF_approved_software_licences
##   http://en.wikipedia.org/wiki/List_of_OSI_approved_software_licences
## for more information.
## </NOTE>

re_anchor <-
function(s)
    if(length(s)) paste0("^", s, "$") else character()

re_group <-
function(s)
    if(length(s)) paste0("(", s, ")") else character()

re_or <-
function(s, group = TRUE) {
    if(!length(s))
        character()
    else if(group)
        re_group(paste(s, collapse = "|"))
    else
        paste(s, collapse = "|")
}

.make_R_license_db <-
function(paths = NULL)
{
    if(is.null(paths))
        paths <- unlist(strsplit(Sys.getenv("R_LICENSE_DB_PATHS"),
                                 .Platform$path.sep, fixed = TRUE))
    paths <- c(paths,
               file.path(R.home("share"), "licenses", "license.db"))
    ldb <- Reduce(function(u, v) merge(u, v, all = TRUE), 
                  lapply(unique(normalizePath(paths)), read.dcf))
    ## Merging matrices gives a data frame.
    ldb <- as.matrix(ldb)
    ldb[is.na(ldb)] <- ""
    ## (Could also keep NAs and filter on is.finite() in subsequent
    ## computations.)
    ## FOSS == "yes" implues Restricts_use = "no":
    ldb[ldb[, "FOSS"] == "yes", "Restricts_use"] <- "no"
    ldb <- data.frame(ldb, stringsAsFactors = FALSE)
    ldb$Labels <- R_license_db_labels(ldb)
    ldb[!duplicated(ldb$Labels), ]
}

R_license_db_labels <-
function(ldb)
{
    if(is.null(ldb)) return(NULL)
    lab <- ldb$SSS
    pos <- which(lab == "")
    abbrevs <- ldb$Abbrev[pos]
    versions <- ldb$Version[pos]
    lab[pos] <- ifelse(abbrevs != "", abbrevs, ldb$Name[pos])
    ind <- nzchar(versions)
    pos <- pos[ind]
    lab[pos] <- sprintf("%s version %s", lab[pos], versions[ind])
    lab
}

R_license_db <- local({
    val <- NULL
    function(new) {
        if(!missing(new))
            val <<- new
        else
            val
    }
})

R_license_db(.make_R_license_db())

.make_R_license_db_vars <-
function()
{
    ## Build license regexps and tables according to the specs.

    ldb <- R_license_db()

    ## Standard short specification (SSS field) from the R license db.
    pos <- which(nzchar(ldb$SSS))
    names(pos) <- ldb$SSS[pos]
    tab_sss <- pos

    has_version <- nzchar(ldb$Version)
    has_abbrev <- nzchar(ldb$Abbrev)

    ## Name or abbreviation of an unversioned license from the R license
    ## db.
    pos <- which(!has_version)
    names(pos) <- ldb$Name[pos]
    tab_unversioned <- pos
    pos <- which(has_abbrev & !has_version)
    tab_unversioned[ldb$Abbrev[pos]] <- pos

    ## Versioned licenses from the R license db.
    ## Style A: Name of abbreviation of a versioned license, optionally
    ##   followed by a version spec
    ## Style B: Name of a versioned license followed by the version.
    ## Style C: Abbrevation of a versioned license combined with '-'.
    pos <- which(has_version)
    names(pos) <- ldb$Name[pos]
    tab_versioned_style_A <- split(pos, names(pos))
    tab_versioned_style_B <- pos
    names(tab_versioned_style_B) <-
        paste(names(pos), ldb$Version[pos])
    pos <- which(has_version & has_abbrev)
    tab_versioned_style_A <-
        c(tab_versioned_style_A, split(pos, ldb$Abbrev[pos]))
    tab_versioned_style_C <- pos
    names(tab_versioned_style_C) <-
        sprintf("%s-%s",
                ldb$Abbrev[pos],
                ldb$Version[pos])

    operators <- c("<", "<=", ">", ">=", "==", "!=")
    re_numeric_version <- .standard_regexps()$valid_numeric_version
    re_single_version_spec <-
        paste0("[[:space:]]*",
               re_or(operators),
               "[[:space:]]*",
               re_group(re_numeric_version),
               "[[:space:]]*")
    re_version_spec <-
        paste0("\\(",
               paste0("(", re_single_version_spec, ",)*"),
               re_single_version_spec,
               "\\)")

    re_sss <- re_or(names(tab_sss))
    re_unversioned <- re_or(names(tab_unversioned))
    re_versioned_style_A <-
        paste0(re_or(names(tab_versioned_style_A)),
               "[[:space:]]*",
               paste0("(", re_version_spec, ")*"))
    ## Let's be nice ...
    re_versioned_style_B <-
        re_or(paste0(ldb$Name[has_version],
                     "[[:space:]]+([Vv]ersion[[:space:]]+)?",
                     ldb$Version[has_version]))
    re_versioned_style_C <- re_or(names(tab_versioned_style_C))

    re_license_in_db <-
        re_or(c(re_sss,
                re_unversioned,
                re_versioned_style_A,
                re_versioned_style_B,
                re_versioned_style_C))

    re_license_file <- "file LICEN[CS]E"
    re_license_extension <-
        sprintf("[[:space:]]*\\+[[:space:]]*%s", re_license_file)

    ## <NOTE>
    ## Many standard licenses actually do not allow extensions.
    ## Ideally, we would only allow the extension markup for extensible
    ## standard licenses, as identified via an Extensible: TRUE field in
    ## the license db.  But version ranges make this tricky: e.g.,
    ##   GPL (>= 2) + file LICENSE
    ## is not right as GPL-2 does not allow extensions ...
    ## Hence, for now allow the extension markup with all standard
    ## licenses.
    ## </NOTE>

    re_component <-
        re_anchor(re_or(c(sprintf("%s(%s)?",
                                  re_license_in_db,
                                  re_license_extension),
                          re_license_file,
                          "Unlimited")))
    list(re_component = re_component,
         re_license_file = re_license_file,
         re_license_extension = re_license_extension,
         re_single_version_spec = re_single_version_spec,
         re_sss = re_sss,
         re_unversioned = re_unversioned,
         re_versioned_style_A = re_versioned_style_A,
         re_versioned_style_B = re_versioned_style_B,
         re_versioned_style_C = re_versioned_style_C,
         tab_sss = tab_sss,
         tab_unversioned = tab_unversioned,
         tab_versioned_style_A = tab_versioned_style_A,
         tab_versioned_style_B = tab_versioned_style_B,
         tab_versioned_style_C = tab_versioned_style_C)
}

R_license_db_vars <- local({
    val <- NULL
    function(new) {
        if(!missing(new))
            val <<- new
        else
            val
    }
})


R_license_db_vars(.make_R_license_db_vars())

R_license_db_refresh_cache <-
function(paths = NULL)
{
    R_license_db(.make_R_license_db(paths))
    R_license_db_vars(.make_R_license_db_vars())
}

## Standardizable license specs:

## License specifications found on CRAN/BioC/Omegahat and manually
## classified as standardizable software licenses (even though not
## standardized/canonical), provided as a list of license specs named by
## the respective standardizations.
## With ongoing standardization this should gradually be eliminated.
## Last updated: 2009-02-19.

## Nasty issues.
## * There really is no GPL version 2.0.
##   Unfortunately, the FSF uses 2.0 in URLs or links
##   (http://www.gnu.org/licenses/old-licenses/gpl-2.0.html)
##   The text clearly says "Version 2, June 1991".
## * There really is no LGPL version 2.0.
##   Unfortunately, the FSF uses 2.0 in URLs or links
##   (http://www.gnu.org/licenses/old-licenses/).
##   The text clearly says "Version 2, June 1991".
## * CeCILL is a bit of a mess: the current version is referred to as
##   "version 2" (http://www.cecill.info/licences.en.html) but
##    internally uses "Version 2.0 dated 2006-09-05"
##    (http://www.cecill.info/licences/Licence_CeCILL_V2-en.txt).

.standardizable_license_specs <-
list("Artistic-2.0" =
     c("The Artistic License, Version 2.0",
       "Artistic 2.0",
       "Artistic-2.0, see http://www.opensource.org/licenses/artistic-license-2.0.php"
       ),

     "BSL" =
     c("Boost Software License",
       "Boost Software License 1.0",
       "BSL 1.0"
       ),

     "CeCILL-2" =
     c("CeCILL-2.0"
       ),

     "GPL" =
     c("GNU Public License",
       "Gnu GPL",
       "GNU GPL",
       "GPL (http://www.gnu.org/copyleft/gpl.html)"
       ),

     "GPL-2" =
     c(## <NOTE>
       ## There is no GPL 2.0, see above.
       "GNU General Public License 2.0.",
       "GPL 2.0",
       "GPL version 2.0",
       "GPL2.0",
       ## </NOTE>
       "GPL Version 2",
       "GNU GPL Version 2",
       "GNU GPL version 2",
       "GNU GPL version 2.",
       "GPL (version 2)",
       "GPL 2",
       "GPL 2.",
       "GPL version 2",
       "GPL version 2 (June, 1991)",
       "GPL version 2.",
       "GPL2",
       ## BioC:
       "GPL V2",
       "GPL, version 2"
       ),

     "GPL-3" =
     c("GPL Version 3",
       "GPL version 3",
       "GNU General Public Licence (GPLv3)",
       "GPL 3",
       "GPL v3"
       ),

     "GPL (>= 2)" =
     c(## <NOTE>
       ## There is no GPL 2.0, see above.
       "GNU GPL v2.0 or greater",
       "GPL 2.0 or higher",
       "GPL 2.0 or newer",
       "GPL version 2.0 or later",
       "GPL version 2.0 or newer",
       ## </NOTE>
       "GNU GPL (version 2 or later)",
       "GNU GPL (version 2 or later); see the file COPYING for details",
       "GNU GPL version 2 or newer",
       "GNU General Public License version 2 or newer",
       "GPL version 2 or later",
       "GPL ( version 2 or later)",
       "GPL (Version 2 or above)",
       "GPL (Version 2 or later)",
       "GPL (version 2 or higher)",
       "GPL (version 2 or later)",
       "GPL (version 2 or later, see the included file GPL)",
       "GPL (version 2 or newer)",
       "GPL 2 or later",
       "GPL 2 or newer",
       "GPL version 2 or any later version",
       "GPL Version 2 or later",
       "GPL Version 2 or later.",
       "GPL Version 2 or newer",
       "GPL Version 2 or newer.",
       "GPL version 2 (June, 1991) or later",
       "GPL version 2 (or newer)",
       "GPL version 2 or later.",
       "GPL version 2 or newer",
       "GPL version 2 or newer (http://www.gnu.org/copyleft/gpl.html)",
       "GPL version 2 or newer (see README).",
       "GPL version 2 or newer.",
       "GPL version 2 or newer. http://www.gnu.org/copyleft/gpl.html",
       "GPL version 2, or, at your option, any newer version.",
       "GPL Version 2 (or later)",
       "GPL version 2 (or later)",
       "GPL version 2 or higher",
       "GPL2 or later",
       "GPL>=2",
       "GNU General Public License (version 2 or later)"
       ),

     "GPL (>= 3)" =
     c("GPL (version 3 or later)",
       "GPL >=3"
       ),

     "GPL | LGPL" =
     c("GPL or LGPL by your choice"
       ),

     "GPL | BSD" =
     c("GPL, BSD"
       ),

     "GPL-2 | file LICENSE" =
     c("use under GPL2, or see file LICENCE"
       ),

     "LGPL" =
     c("LGPL (see <http://www.opensource.org/licenses/lgpl-license.php>).",
       "GNU LGPL (same as wxWidgets)."
       ),

     "LGPL-2" =
     c("LGPL2",
       "LGPL2.0"
       ),

     "LGPL-2.1" =
     c("LGPL version 2.1"
       ),

     "LGPL-3" =
     c("LGPL-v3"
       ),

     "LGPL (>= 2.0)" =
     c(## <NOTE>
       ## There is no LGPL-2.0, see above.
       "LGPL >= 2.0",
       ## </NOTE>
       "LGPL Version 2 or later.",
       "LGPL version 2 or newer",
       "LGPL (version 2 or later)",
       "LGPL version 2 or later"
       ),

     "LGPL (>= 2.1)" =
     c("LGPL version 2.1 or later"
       ),

     "LGPL (>= 3.0)" =
     c("LGPL >=3"
       ),

     "X11" =
     c("X11 (http://www.x.org/Downloads_terms.html)"
       ),

     "Unlimited" =
     c("Unlimited use and distribution."
       )
)

.standardizable_license_specs_db <-
data.frame(ispecs =
           unlist(.standardizable_license_specs),
           ospecs =
           rep.int(names(.standardizable_license_specs),
                   sapply(.standardizable_license_specs,
                          length)),
           stringsAsFactors = FALSE)

analyze_license <-
function(x)
{
    .make_results <- function(is_empty = FALSE,
                              is_canonical = FALSE,
                              bad_components = character(),
                              is_standardizable = FALSE,
                              is_verified = FALSE,
                              standardization = NA_character_,
                              components = NULL,
                              expansions = NULL,
                              extensions = NULL,
                              pointers = NULL,
                              is_FOSS = NA,
                              restricts_use = NA)
        list(is_empty = is_empty,
             is_canonical = is_canonical,
             bad_components = bad_components,
             is_standardizable = is_standardizable,
             is_verified = is_verified,
             standardization = standardization,
             components = components,
             expansions = expansions,
             extensions = extensions,
             pointers = pointers,
             is_FOSS = is_FOSS,
             restricts_use = restricts_use)


    x <- .strip_whitespace(x)
    if(is.na(x) || (x == "")) {
        ## Not really a lot to check ...
        ## (Note that non-standardizable license specs are dropped by
        ## writePACKAGES() and friends.)
        return(.make_results(is_empty = TRUE))
    }

    pointers <- NULL
    extensions <- NULL
    expansions <- NULL
    is_verified <- FALSE
    is_FOSS <- NA
    restricts_use <- NA

    ## Try splitting into the individual components.
    components <-
        .strip_whitespace(unlist(strsplit(x, "|", fixed = TRUE)))

    ## Now analyze the individual components.
    ok <- grepl(R_license_db_vars()$re_component, components)
    bad_components <- components[!ok]
    is_canonical <- all(ok)

    ## Is the license specification standardizable?
    standardizable <-
        components %in% .standardizable_license_specs_db$ispecs
    is_standardizable <- (is_canonical || all(standardizable))

    standardization <- if(is_standardizable) {
        ## Standardize the ones which are standardizable but not yet
        ## standardized.
        ind <- !ok & standardizable
        if(any(ind))
            components[ind] <-
                .standardize_license_components(components[ind])
        ## Canonicalize the standardized ones a bit more (as we are
        ## rather generous about using whitespace).
        ind <- ok & grepl("\\(", components)
        if(any(ind)) {
            s <- sub("[[:space:]]*\\([[:space:]]*", " \\(",
                     components[ind])
            s <- sub("[[:space:]]*\\)", "\\)", s)
            s <- gsub("[[:space:]]*,[[:space:]]*", ", ", s)
            ## Really re_or(operators) ...
            s <- gsub("[[:space:]]+(<=?|>=?|==|!=)", " \\1", s)
            components[ind] <-
                gsub(sprintf("[[:space:]]*(%s)",
                             .standard_regexps()$valid_numeric_version),
                     " \\1", s)
        }
        paste(components, collapse = " | ")
    } else NA_character_

    ## Analyze components provided that we know we can standardize.
    if(is_standardizable) {
        verifiable <- function(x, v = "yes")
            !is.null(x) && all(!is.na(x) & (x == v))
        ## (More generally we could test for positive length of x: but
        ## a length test is needed because all(NULL) |=> TRUE.)
        
        expansions <- lapply(components,
                             expand_license_spec_component_from_db)

        ## The license is FOSS if there is one component which is
        ## "Unlimited" or has a positive number of expansions all of
        ## which are FOSS.
        ## If all components have a positive number of expansions where
        ## at least one is not FOSS, the license is not FOSS.
        ## Otherwise we do not know.
        is_FOSS <- if(any(components == "Unlimited")) {
            TRUE
        } else if(any(sapply(expansions,
                             function(e) verifiable(e$FOSS)))) {
            TRUE
        } else if(all(sapply(expansions,
                             function(e) any(e$FOSS == "no")))) {
            FALSE
        } else
            NA

        ## The license is verified (as FOSS) if it was verified as FOSS.
        is_verified <- !is.na(is_FOSS) && is_FOSS

        ## The license does not restrict use if it is verified as FOSS,
        ## or if there is one component with a positive number of
        ## expansions all of which do not restrict use.
        ## If all components have a positive number of expansions where
        ## at least one of which restricts use, the license restricts
        ## use.
        ## Otherwise, we do not know.
        restricts_use <- if(is_verified) {
            FALSE
        } else if(any(sapply(expansions,
                             function(e)
                             (length(e) &&
                              all(e$Restricts_use == "no"))))) {
            FALSE
        } else if(all(sapply(expansions,
                             function(e)
                             any(e$Restricts_use == "yes")))) {
            TRUE
        } else
            NA

        re <- R_license_db_vars()$re_license_file
        pos <- grep(sprintf("%s$", re), components)
        if(length(pos)) {
            elements <- components[pos]
            ## Components with license file pointers.
            pointers <- sub(".*file ", "", elements)
            ## Components with license extensions.
            ind <- grepl("+", elements, fixed = TRUE)
            if(any(ind))
                extensions <-
                    data.frame(components = elements[ind],
                               extensible =
                               sapply(expansions[pos[ind]],
                                      function(e)
                                      verifiable(e$Extensible)),
                               stringsAsFactors = FALSE)
        }

        ## Replace expansions by their labels from the license db.
        ## (As these are unique, we can always easily get the full
        ## expansions back.)
        expansions <- lapply(expansions, `[[`, "Labels")
        ## Components which are "Unlimited" or "file LICEN[CS]E" have
        ## empty expansions:
        ind <- grepl(sprintf("^(Unlimited|%s)$", re), components)
        if(any(ind)) expansions[ind] <- as.list(components[ind])
        ## Components with license extensions have this dropped in the
        ## expansion.
        m <- regexpr(sprintf("\\+ *%s$", re), components)
        ind <- (m > -1L)
        expansions[ind] <-
            Map(paste, expansions[ind], regmatches(components, m))
    }

    .make_results(is_canonical = is_canonical,
                  bad_components = bad_components,
                  is_standardizable = is_standardizable,
                  standardization = standardization,
                  is_verified = is_verified,
                  components = components,
                  expansions = expansions,    
                  extensions = extensions,
                  pointers = pointers,
                  is_FOSS = is_FOSS,
                  restricts_use = restricts_use)
}

.standardize_license_components <-
function(x)
{
    with(.standardizable_license_specs_db,
         ospecs[match(x, ispecs)])
}

analyze_licenses <-
function(x, db = NULL)
{
    x <- as.character(x)
    if(!length(x)) return(NULL)
    ## As analyzing licenses is costly, only analyze the unique specs.
    v <- unique(x)
    out <- as.data.frame(do.call(rbind, lapply(v, analyze_license)),
                         stringsAsFactors = FALSE)
    pos <- match(c("is_empty", "is_canonical", "is_standardizable",
                   "is_verified", "standardization", "is_FOSS",
                   "restricts_use"),
                 names(out))
    out[pos] <- lapply(out[pos], unlist)
    ## And re-match specs to the unique specs.
    out <- out[match(x, v), ]
    rownames(out) <- NULL
    if(!is.null(db)) {
        ## db should be a package db (data frame or character matrix)
        ## with rows corresponding to the elements of x.
        cnms <- colnames(db)
        if(!is.na(pos <- match("License_is_FOSS", cnms))) {
            lif <- db[, pos]
            pos <- which(!is.na(lif))
            out$is_FOSS[pos] <- out$is_verified[pos] <-
                (lif[pos] == "yes")
            ## is_FOSS implies !restricts_use:
            pos <- pos[lif[pos] == "yes"]
            out$restricts_use[pos] <- FALSE
        }
        if(!is.na(pos <- match("License_restricts_use", cnms))) {
            lru <- db[, pos]
            pos <- which(!is.na(lru))
            out$restricts_use[pos] <- (lru[pos] == "yes")
            ## restricts_use implies !is_FOSS:
            pos <- pos[lru[pos] == "yes"]
            out$is_FOSS[pos] <- out$is_verified[pos] <- FALSE
        }
    }
    out
}

build_license_db <-
function(dir, unpacked = FALSE)
{
    CRAN <- getOption("repos")["CRAN"]
    if(missing(dir) && substring(CRAN, 1L, 7L) == "file://")
        dir <- file.path(substring(CRAN, 8L), "src", "contrib")

    fields <- c("License", "License_is_FOSS", "License_restricts_use",
                "Maintainer")
    db <- .build_repository_package_db(dir, fields, unpacked = unpacked)
    ## Actually, for Omegehat this is not a good idea as this retains
    ## old versions in the "main" src/contrib directory.  But let's not
    ## worry about this for now ...

    db <- do.call("rbind", db)

    ## Retain what is needed ...
    data.frame(db[ , c("Package", "Version", fields)],
               stringsAsFactors = FALSE)
}

analyze_licenses_in_license_db <-
function(db)
{
    results <- cbind(db, analyze_licenses(db$License, db))
    ## Keep License_is_FOSS and License_restricts_use columns for now,
    ## so that we can identify the is_FOSS and restricts_use values
    ## obtained from these.
    results
}

analyze_licenses_in_repository <-
function(dir, unpacked = FALSE, full = TRUE)
{
    db <- build_license_db(dir, unpacked)
    if(!full) {
        ## Only keep the highest available versions.
        ## Such an option might be useful for build_license_db()
        ## itself.
        db <- .remove_stale_dups(db)
    }
    analyze_licenses_in_license_db(db)
}

summarize_license_db <-
function(db)
{
    packages <- db$Package
    if(any(duplicated(packages)))
        packages <- sprintf("%s_%s", packages, db$Version)
    packages <- split(packages, db$License)
    licenses <- names(packages)
    out <- data.frame(Licenses = licenses, stringsAsFactors = FALSE)
    ## To get the 'packages' list into a data frame without I() ...
    out$Packages <- packages
    cat(formatDL(out$Licenses,
                 sapply(out$Packages,
                        function(p) paste(unique(p), collapse = " ")),
                 style = "list"),
        sep = "\n\n")
    invisible(out)
}

expand_license_spec_component_from_db <-
function(x)
{
    ## Determine the license from the db matching a license spec
    ## component.

    ldb <- R_license_db()
    ldb_vars <- R_license_db_vars()

    .numeric_version_meets_constraints_p <-
    function(version, constraints)
    {
        version <- as.numeric_version(version)
        for(term in constraints) {
            re <- ldb_vars$re_single_version_spec
            op <- sub(re, "\\1", term)
            target <- sub(re, "\\2", term)
            if(!eval(parse(text = paste("version", op, "target"))))
                return(FALSE)
        }
        TRUE
    }
    
    if(x == "Unlimited" ||
       grepl(x, ldb_vars$re_license_file))
        return(NULL)

    ## Drop possible license extension.
    x <- sub(ldb_vars$re_license_extension, "", x)

    if(grepl(re_anchor(ldb_vars$re_sss), x)) {
        pos <- ldb_vars$tab_sss[x]
        ldb[pos, ]
    }
    else if(grepl(re_anchor(ldb_vars$re_unversioned), x)) {
        pos <- ldb_vars$tab_unversioned[x]
        ldb[pos, ]
    }
    else if(grepl(re <-
                  re_anchor(ldb_vars$re_versioned_style_A),
                  x)) {
        ## Extract name/abbrev and version spec.
        v <- sub(re, "\\2", x)
        x <- sub(re, "\\1", x)
        ## First, find the matching entries matching the name/abbrev.
        pos <- ldb_vars$tab_versioned_style_A[[x]]
        entries <- ldb[pos, ]
        ## Now determine the entries satisfying the version spec.
        v <- sub("[[:space:]]*\\((.*)\\)[[:space:]]*", "\\1", v)
        if(v != "") {
            constraints <-
                unlist(strsplit(v, "[[:space:]]*,[[:space:]]*"))
            entries <-
                entries[sapply(entries$Version,
                               .numeric_version_meets_constraints_p,
                               constraints), ]
        }
        entries
    }
    else if(grepl(re_anchor(ldb_vars$re_versioned_style_B),
                  x)) {
        re <- sprintf("[[:space:]]+([Vv]ersion[[:space:]]+)?(%s)",
                      .standard_regexps()$valid_numeric_version)
        x <- sub(re, " \\2", x)
        pos <- ldb_vars$tab_versioned_style_B[x]
        ldb[pos, ]
    }
    else if(grepl(re_anchor(ldb_vars$re_versioned_style_C),
                  x)) {
        pos <- ldb_vars$tab_versioned_style_C[x]
        ldb[pos, ]
    }

}
#  File src/library/tools/R/logging.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/

### emulation of Perl Logfile.pm

newLog <-
function(filename = "")
{
    con <- if(nzchar(filename)) file(filename, "wt") else 0L

    Log <- new.env(parent = emptyenv())
    Log$con <- con
    Log$filename <- filename
    Log$stars <- "*"
    Log$warnings <- 0L
    Log$notes <- 0L

    Log
}

closeLog <-
function(Log)
    if(Log$con > 2L) close(Log$con)

printLog <-
function(Log, ...)
{
    quotes <- function(x) gsub("'([^']*)'", sQuote("\\1"), x)
    args <- lapply(list(...), quotes)
    do.call(cat, c(args, sep = ""))
    if (Log$con > 0L) do.call(cat, c(args, sep = "", file = Log$con))
}

printLog0 <-
function(Log, ...)
{
    cat(..., sep = "")
    if (Log$con > 0L) cat(..., file = Log$con, sep = "")
}

## unused
## setStars <- function(Log, stars) {Log$stars <- stars; Log}

checkingLog <-
function(Log, ...)
    printLog(Log, Log$stars, " checking ", ..., " ...")

creatingLog <-
function(Log, text)
    printLog(Log, Log$stars, " creating ", text, " ...")

messageLog <-
function(Log, ...)
    printLog(Log, Log$stars, " ", ..., "\n")

resultLog <-
function(Log, text)
    printLog(Log, " ", text, "\n")

errorLog <-
function(Log, ...)
{
    resultLog(Log, "ERROR")
    text <- paste0(...)
    if (length(text) && nzchar(text)) printLog(Log, ..., "\n")
}

## <NOTE>
## Perhaps the arguments to errorLog(), warningLog() and noteLog()
## should be synchronized?
## </NOTE>

warningLog <-
function(Log, text = "")
{
    resultLog(Log, "WARNING")
    if(nzchar(text)) printLog(Log, text, "\n")
    Log$warnings <- Log$warnings + 1L
}

noteLog <-
function(Log, text = "")
{
    resultLog(Log, "NOTE")
    if(nzchar(text)) printLog(Log, text, "\n")
    Log$notes <- Log$notes + 1L
}

summaryLog <-
function(Log)
{
    if((Log$warnings > 0L) || (Log$notes > 0L)) {
        if(Log$warnings > 1L)
            printLog(Log,
                     sprintf("WARNING: There were %d warnings.\n",
                             Log$warnings))
        else if(Log$warnings == 1L)
            printLog(Log,
                     sprintf("WARNING: There was 1 warning.\n"))
        if(Log$notes > 1L)
            printLog(Log,
                     sprintf("NOTE: There were %d notes.\n",
                             Log$notes))
        else if(Log$notes == 1L)
            printLog(Log,
                     sprintf("NOTE: There was 1 note.\n"))
        cat(sprintf("See\n  %s\nfor details.\n", sQuote(Log$filename)))
    }
}
#  File src/library/tools/R/makeLazyLoad.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2012 The R 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 of the License, 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/

code2LazyLoadDB <-
    function(package, lib.loc = NULL,
             keep.source = getOption("keep.source.pkgs"),
             compress = TRUE)
{
    pkgpath <- find.package(package, lib.loc, quiet = TRUE)
    if(!length(pkgpath))
        stop(gettextf("there is no package called '%s'", package),
             domain = NA)
    loadenv <- new.env(hash=TRUE)
    codeFile <- file.path(pkgpath, "R", package)
    dbbase <- file.path(pkgpath, "R", package)
    if (packageHasNamespace(package, dirname(pkgpath))) {
        if (! is.null(.getNamespace(as.name(package))))
            stop("namespace must not be already loaded")
        ns <- suppressPackageStartupMessages(loadNamespace(package, lib.loc, keep.source, partial = TRUE))
        makeLazyLoadDB(ns, dbbase, compress = compress)
    }
    else
        stop("all packages should have a NAMESPACE")
}

sysdata2LazyLoadDB <- function(srcFile, destDir, compress = TRUE)
{
    e <- new.env(hash=TRUE)
    load(srcFile, e)
    makeLazyLoadDB(e, file.path(destDir, "sysdata"), compress = compress)
}

list_data_in_pkg <- function(package, lib.loc = NULL, dataDir = NULL)
{
    if(is.null(dataDir)) {
        pkgpath <- find.package(package, lib.loc, quiet = TRUE)
        if(!length(pkgpath))
            stop(gettextf("there is no package called '%s'", package),
                 domain = NA)
        dataDir <- file.path(pkgpath, "data")
    } else {
        pkgpath <- sub("/data$", "", dataDir)
        package <- basename(pkgpath)
	# avoid builddir != srcdir problems -- assume package has been installed
        lib.loc <- c(dirname(pkgpath), .libPaths())
    }
    if(file_test("-d", dataDir)) {
        if(file.exists(sv <- file.path(dataDir, "Rdata.rds"))) {
            ans <- readRDS(sv)
        } else if(file.exists(sv <- file.path(dataDir, "datalist"))) {
            ## BioC mess this file up, of course!
            ans <- strsplit(readLines(sv, warn = FALSE), ":")
            nms <- lapply(ans, function(x) x[1L])
            ans <- lapply(ans, function(x)
                          if(length(x) == 1L) x[1L] else
                          strsplit(x[2L], " +")[[1L]][-1L])
            names(ans) <- nms
        } else {
            files <- list_files_with_type(dataDir, "data")
            ## omit compression extensions
            files <- unique(basename(file_path_sans_ext(files, TRUE)))
            ans <- vector("list", length(files))
            dataEnv <- new.env(hash=TRUE)
            names(ans) <- files
            for(f in files) {
                utils::data(list = f, package = package, lib.loc = lib.loc,
                            envir = dataEnv)
                ans[[f]] <- ls(envir = dataEnv, all.names = TRUE)
                rm(list = ans[[f]], envir = dataEnv)
            }
        }
        ans
    } else NULL
}

data2LazyLoadDB <- function(package, lib.loc = NULL, compress = TRUE)
{
    options(warn=1)
    pkgpath <- find.package(package, lib.loc, quiet = TRUE)
    if(!length(pkgpath))
        stop(gettextf("there is no package called '%s'", package),
             domain = NA)
    dataDir <- file.path(pkgpath, "data")
    ## set the encoding for text files to be read, if specified
    enc <- .read_description(file.path(pkgpath, "DESCRIPTION"))["Encoding"]
    if(!is.na(enc)) {
        op <- options(encoding=enc)
        on.exit(options(encoding=op[[1L]]))
    }
    if(file_test("-d", dataDir)) {
        if(file.exists(file.path(dataDir, "Rdata.rds")) &&
	    file.exists(file.path(dataDir, paste(package, "rdx", sep="."))) &&
	    file.exists(file.path(dataDir, paste(package, "rdb", sep="."))) ){
            warning("package seems to be using lazy loading for data already")
        }
	else {
            dataEnv <- new.env(hash=TRUE)
            tmpEnv <- new.env()
            f0 <- files <- list_files_with_type(dataDir, "data")
            ## omit compression extensions
            files <- unique(basename(file_path_sans_ext(files, TRUE)))
            dlist <- vector("list", length(files))
            names(dlist) <- files
            loaded <- character(0L)
            for(f in files) {
                utils::data(list = f, package = package, lib.loc = lib.loc,
                        envir = dataEnv)
                utils::data(list = f, package = package, lib.loc = lib.loc,
                        envir = tmpEnv)
                tmp <- ls(envir = tmpEnv, all.names = TRUE)
                rm(list = tmp, envir = tmpEnv)
                dlist[[f]] <- tmp
                loaded <- c(loaded, tmp)
            }
            dup <- duplicated(loaded)
            if(any(dup))
                warning(sprintf(ngettext(sum(dup),
                                         "object %s is created by more than one data call",
                                         "objects %s are created by more than one data call"),
                                paste(sQuote(loaded[dup]), collapse=", ")),
                        call. = FALSE, domain = NA)

            if(length(loaded)) {
                dbbase <- file.path(dataDir, "Rdata")
                makeLazyLoadDB(dataEnv, dbbase, compress = compress)
                saveRDS(dlist, file.path(dataDir, "Rdata.rds"),
                         compress = compress)
                unlink(f0)
                if(file.exists(file.path(dataDir, "filelist")))
                    unlink(file.path(dataDir, c("filelist", "Rdata.zip")))
            }
        }
    }
}

makeLazyLoadDB <- function(from, filebase, compress = TRUE, ascii = FALSE,
                           variables)
{
    envlist <- function(e)
        .Internal(getVarsFromFrame(ls(e, all.names = TRUE), e, FALSE))

    envtable <- function() {
        idx <- 0
        envs <- NULL
        enames <- character(0L)
        find <- function(v, keys, vals) {
            for (i in seq_along(keys))
                if (identical(v, keys[[i]]))
                    return(vals[i])
	    NULL
	}
        getname <- function(e) find(e, envs, enames)
        getenv <- function(n) find(n, enames, envs)
        insert <- function(e) {
            idx <<- idx + 1
            name <- paste("env", idx, sep="::")
            envs <<- c(e, envs)
            enames <<- c(name, enames)
            name
        }
        list(insert = insert, getenv = getenv, getname = getname)
    }

    lazyLoadDBinsertValue <- function(value, file, ascii, compress, hook)
        .Internal(lazyLoadDBinsertValue(value, file, ascii, compress, hook))

    lazyLoadDBinsertListElement <- function(x, i, file, ascii, compress, hook)
        .Internal(lazyLoadDBinsertValue(x[[i]], file, ascii, compress, hook))

    lazyLoadDBinsertVariable <- function(n, e, file, ascii, compress, hook) {
        x <- .Internal(getVarsFromFrame(n, e, FALSE))
       .Internal(lazyLoadDBinsertValue(x[[1L]], file, ascii, compress, hook))
    }

    mapfile <- paste(filebase, "rdx", sep = ".")
    datafile <- paste(filebase, "rdb", sep = ".")
    close(file(datafile, "wb")) # truncate to zero
    table <- envtable()
    varenv <- new.env(hash = TRUE)
    envenv <- new.env(hash = TRUE)

    envhook <- function(e) {
        if (is.environment(e)) {
            name <- table$getname(e)
            if (is.null(name)) {
                name <- table$insert(e)
                data <- list(bindings = envlist(e),
                             enclos = parent.env(e),
                             attributes = attributes(e),
                             isS4 = isS4(e),
                             locked = environmentIsLocked(e))
                key <- lazyLoadDBinsertValue(data, datafile, ascii,
                                             compress, envhook)
                assign(name, key, envir = envenv)
            }
            name
        }
    }

    if (is.null(from) || is.environment(from)) {
        if (! missing(variables))
            vars <- variables
        else vars <- ls(from, all.names = TRUE)
    }
    else if (is.list(from)) {
        vars <- names(from)
        if (length(vars) != length(from) || any(!nzchar(vars)))
            stop("source list must have names for all elements")
    }
    else stop("source must be an environment or a list")

    for (i in seq_along(vars)) {
        key <- if (is.null(from) || is.environment(from))
            lazyLoadDBinsertVariable(vars[i], from, datafile,
                                     ascii, compress,  envhook)
        else lazyLoadDBinsertListElement(from, i, datafile, ascii,
                                         compress, envhook)
        assign(vars[i], key, envir = varenv)
    }

    vals <- lapply(vars, get, envir = varenv, inherits = FALSE)
    names(vals) <- vars

    rvars <- ls(envenv, all.names = TRUE)
    rvals <- lapply(rvars, get, envir = envenv, inherits = FALSE)
    names(rvals) <- rvars

    val <- list(variables = vals, references = rvals,
                compressed = compress)
    saveRDS(val, mapfile)
}

makeLazyLoading <-
    function(package, lib.loc = NULL, compress = TRUE,
             keep.source = getOption("keep.source.pkgs"))
{
    if(!is.logical(compress) && ! compress %in% c(2,3))
        stop("invalid value for 'compress': should be FALSE, TRUE, 2 or 3")
    options(warn = 1L)
    findpack <- function(package, lib.loc) {
        pkgpath <- find.package(package, lib.loc, quiet = TRUE)
        if(!length(pkgpath))
            stop(gettextf("there is no package called '%s'", package),
                 domain = NA)
        pkgpath
    }

    if (package == "base")
        stop("this cannot be used for package 'base'")

    loaderFile <- file.path(R.home("share"), "R", "nspackloader.R")
    pkgpath <- findpack(package, lib.loc)
    codeFile <- file.path(pkgpath, "R", package)

    if (!file.exists(codeFile)) {
        warning("package contains no R code")
        return(invisible())
    }
    if (file.info(codeFile)["size"] == file.info(loaderFile)["size"])
        warning("package seems to be using lazy loading already")
    else {
        code2LazyLoadDB(package, lib.loc = lib.loc,
                        keep.source = keep.source, compress = compress)
        file.copy(loaderFile, codeFile, TRUE)
    }

    invisible()
}
#  File src/library/tools/R/md5.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2012 The R 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 of the License, 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/

md5sum <- function(files)
    structure(.Call(Rmd5, files), names=files)

.installMD5sums <- function(pkgDir, outDir = pkgDir)
{
    dot <- getwd()
    if (is.null(dot))
        stop("current working directory cannot be ascertained")
    setwd(pkgDir)
    x <- md5sum(dir(".", recursive=TRUE))
    setwd(dot)
    x <- x[names(x) != "MD5"]
    cat(paste(x, names(x), sep=" *"), sep="\n",
        file=file.path(outDir, "MD5"))
}

checkMD5sums <- function(package, dir)
{
    if(missing(dir)) dir <- find.package(package, quiet = TRUE)
    if(!length(dir)) return(NA)
    md5file <- file.path(dir, "MD5")
    if(!file.exists(md5file)) return(NA)
    inlines <- readLines(md5file)
    ## now split on the first space.
    xx <- sub("^([0-9a-fA-F]*)(.*)", "\\1", inlines)
    nmxx <- names(xx) <- sub("^[0-9a-fA-F]* [ |*](.*)", "\\1", inlines)
    dot <- getwd()
    if (is.null(dot))
        stop("current working directory cannot be ascertained")
    setwd(dir)
    x <- md5sum(dir(dir, recursive = TRUE))
    setwd(dot)
    x <- x[names(x) != "MD5"]
    nmx <- names(x)
    res <- TRUE
    not.here <- !(nmxx %in% nmx)
    if(any(not.here)) {
        res <- FALSE
        if (sum(not.here) > 1L)
            cat("files", paste(sQuote(nmxx[not.here]), collapse = ", "),
                "are missing\n", sep = " ")
        else
            cat("file", sQuote(nmxx[not.here]), "is missing\n", sep = " ")
    }
    nmxx <- nmxx[!not.here]
    diff <- xx[nmxx] != x[nmxx]
    if(any(diff)) {
        res <- FALSE
        files <- nmxx[diff]
        if(length(files) > 1L)
            cat("files", paste(sQuote(files), collapse = ", "),
                "have the wrong MD5 checksums\n", sep = " ")
        else cat("file", sQuote(files), "has the wrong MD5 checksum\n")
    }
    res
}
#  File src/library/tools/R/news.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/


## .build_news_db_from_R_NEWS <-
## function()
## {
##     db <- readNEWS(chop = "keepAll")
##     ## This currently is a list of x.y lists of x.y.z lists of
##     ## categories list of entries.
##     flatten <- function(e)
##         cbind(rep.int(names(e), sapply(e, length)),
##               unlist(lapply(e,
##                             function(s) {
##                                 ## Also remove leading white space and
##                                 ## trailing blank lines.
##                                 lapply(s,
##                                        function(e)
##                                            sub("[[:space:]]*$", "",
##                                                paste(sub("^ ", "", e),
##                                                      collapse = "\n")))
##                             }),
##                             use.names = FALSE))
##     db <- lapply(Reduce(c, db), flatten)
##     db <- do.call(rbind, Map(cbind, names(db), db))
##     ## Squeeze in an empty date column.
##     .make_news_db(cbind(db[, 1L], NA_character_, db[, -1L]),
##                   logical(nrow(db)))
## }

.build_news_db <-
function(package, lib.loc = NULL, format = NULL, reader = NULL)
{
    dir <- system.file(package = package, lib.loc = lib.loc)
    ## Or maybe use find.package()?

    ## <FIXME>
    ## We had planned to eventually add support for DESCRIPTION
    ##   News/File
    ##   News/Format
    ##   News/Reader
    ##   News/Reader@R
    ## entries.  But now that we're moving to NEWS.Rd, there seems
    ## little point in providing format/reader support ...
    ## </FIXME>

    ## Look for new-style inst/NEWS.Rd installed as NEWS.Rd.
    ## If not found, look for old-style
    ##   NEWS inst/NEWS
    ## installed as NEWS (and ignore ChangeLog files).
    nfile <- file.path(dir, "NEWS.Rd")
    if(file_test("-f", nfile))
        return(.build_news_db_from_package_NEWS_Rd(nfile))

    nfile <- file.path(dir, "NEWS")
    if(!file_test("-f", nfile))
        return(invisible())
    ## Return NULL for now, no message that there is no NEWS or
    ## ChangeLog file.

    if(!is.null(format))
        .NotYetUsed("format", FALSE)
    if(!is.null(reader))
        .NotYetUsed("reader", FALSE)

    reader <- .news_reader_default

    reader(nfile)
}

.news_reader_default <-
function(file)
{
    verbose <- getOption("verbose")

    .collapse <- function(s) paste(s, collapse = "\n")

    lines <- readLines(file, warn = FALSE)

    ## Re-encode if necessary.
    if(any(ind <- is.na(nchar(lines, allowNA = TRUE)))) {
        dir <- dirname(file)
        if(basename(dir) == "inst")
            dir <- dirname(file)
        ## This should now contain the DESCRIPTION file.
        encoding <-
            if(file.exists(dfile <- file.path(dir, "DESCRIPTION")))
                .read_description(dfile)["Encoding"]
            else
                NA
        if(!is.na(encoding))
            lines[ind] <- iconv(lines[ind], encoding, "")
        ## Last resort.
        if(any(is.na(nchar(lines[ind], allowNA = TRUE))))
            lines[ind] <- iconv(lines[ind], "", "", sub = "byte")
    }

    ## Save what we read in case we cannot figure out the news, in which
    ## case we simply return one entry with the whole text.
    olines <- lines
    ## Get rid of underlines and friends.
    lines <-
        lines[!grepl("^[[:space:]]*[[:punct:]]*[[:space:]]*$", lines)]

    ## Determine lines containing version numbers, without being too
    ## liberal.
    re_valid_package_name <- .standard_regexps()$valid_package_name
    re_v <- sprintf("^([[:space:]]*(%s)|(%s))(%s).*$",
                    paste("CHANGES? *(IN|FOR).*VERSION *",
                          "CHANGES? *(IN|FOR|TO) *",
                          sep = "|"),
                    sprintf(paste(## TeachingDemos pomp ouch
                                  "NEW IN .*",
                                  ## HyperbolicDist nls2 proto
                                  "VERSION:? *",
                                  "%s +",
                                  ## E.g., lattice:
                                  ##   Changes in lattice 0.17
                                  "CHANGES IN %s +",
                                  ## sv*
                                  "== Changes in %s +",
                                  ## tcltk2
                                  "== Version +",
                                  ## R2WinBUGS
                                  "update *",
                                  "v *",
                                  "",
                                  sep = "|"),
                            re_valid_package_name,
                            re_valid_package_name,
                            re_valid_package_name),
                    .standard_regexps()$valid_package_version
                    )
    ## Some people use
    ##   $PACKAGE version $VERSION
    ## Let us try handling this later, or ask people to write their own
    ## readers.
    ind <- grepl(re_v, lines, ignore.case = TRUE)

    if(!any(ind))
        return(.make_news_db(cbind(NA_character_,
                                   NA_character_,
                                   NA_character_,
                                   .collapse(olines))))
    ## Could add an empty list of bad chunks (as none were found).

    ## Everything before the first version line is a header which will
    ## be dropped.
    if(!ind[1L]) {
	pos <- seq_len(which.max(ind) - 1L)
        lines <- lines[-pos]
        ind <- ind[-pos]
    }

    ## Try catching date entries at the end of version lines as well.
    re_d <- sprintf("^.*(%s)[[:punct:][:space:]]*$",
                    "[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}")
    ## Could try to allow for non ISO date specs ...

    ## Version lines determine the chunks, which after the version line
    ## should either start with a line tag (category) or an itemize
    ## "bullet".
    chunks <- split(lines, cumsum(ind))

    do_chunk <- function(chunk, header = NA_character_) {
        ## Process a single chunk.

        ## If there is no category header, the first line is the version
        ## line, after which the next non blank line should start with a
        ## line tag (category) or an itemize "bullet".
        if(!is.na(header))
            date <- NA_character_
        else {
            txt <- chunk[1L]
            header <- sub(re_v, "\\6", txt, ignore.case = TRUE)
            date <- if(grepl(re_d, txt, perl = TRUE))
                sub(re_d, "\\1", txt, perl = TRUE)
            else
                NA_character_
        }

        lines <- chunk[-1L]
        s <- .collapse(lines)
        if(grepl("^[[:space:]]*([o*+-])", s)) {
            sep <- sub("^[[:space:]]*([o*+-]).*$", "\\1", s)
            ire <- sprintf("^[[:space:]]*([%s])[[:space:]]+", sep)
            ind <- grepl(ire, lines)
            list(entries =
                 sapply(split(lines, cumsum(ind)),
                        function(s)
                        sub(ire, "", .collapse(sub("^\t?", "", s)))
                        ),
                 header = header,
                 chunk = chunk,
                 date = date)
        } else {
            ## Categories should be non-empty starting in column 1.
            re_c <- "^([[:alpha:]].*)[[:space:]]*$"
            ind <- grepl(re_c, lines)
            ## If we detect neither bullet items nor categories, the
            ## chunk is in a different format than we can recognize.
            ## Return no entries, and have the finisher give the whole
            ## chunk and push it onto the bad chunk list.
            if(!any(ind)) {
                list(entries = character(),
                     header = header,
                     chunk = chunk,
                     date = date)
            } else {
                pos <- cumsum(ind) > 0
                list(entries =
                     Map(do_chunk,
                         split(lines[pos], cumsum(ind)[pos]),
                         sub("[[:punct:]]*$", "",
                             sub(re_c, "\\1", lines[ind]))),
                     header = header,
                     chunk = chunk,
                     date = date)
            }
        }
    }

    out <- lapply(chunks, do_chunk)
    ## Now assemble pieces.
    reporter <- function(x) {
        if(verbose)
            message(gettextf("Cannot process chunk/lines:\n%s",
                             .collapse(x)))
        NULL
    }
    finisher <- function(x) {
        entries <- x$entries
        version <- x$header
        date <- x$date
        if(is.list(entries)) {
            do.call(rbind,
                    lapply(entries,
                           function(x) {
                               entries <- x$entries
                               bad <- if(!length(entries)) {
                                   reporter(x$chunk)
                                   entries <-
                                       sub("^[[:space:]]*", "",
                                           .collapse(x$chunk[-1L]))
                                   TRUE
                               }
                               else FALSE
                               cbind(version, date, x$header, entries,
                                     bad)
                           }))
        }
        else {
            bad <- if(!length(entries)) {
                reporter(x$chunk)
                entries <-
                    sub("^[[:space:]]*", "",
                        .collapse(x$chunk[-1L]))
                TRUE
            }
            else FALSE
            cbind(version, date, NA_character_, entries, bad)
        }
    }

    out <- do.call(rbind, lapply(out, finisher))

    ## Try to remove a common 'exdent' from the entries.
    entries <- out[, 4L]
    exdent <-
        unlist(lapply(gregexpr("\n *", entries), attr, "match.length"))
    exdent <- exdent[exdent > 1L]
    if(length(exdent)) {
        out[, 4L] <-
            gsub(sprintf("\n%s",
                         paste(rep.int(" ", min(exdent) - 1L),
                               collapse = "")),
                 "\n", entries)
    }

    .make_news_db(out[, -5L, drop = FALSE], as.logical(out[, 5L]))
}

.make_news_db <-
function(x, bad = NULL, classes = NULL)
{
    ## Expect x to be a 4 column
    ##   version date category text
    ## character matrix.
    ## Could of course check for this using
    ##   if(!is.character(x) || ncol(x) != 4L)
    out <- data.frame(x, row.names = NULL, stringsAsFactors = FALSE)
    ## Note that we cannot do
    ##   dimnames(out) <- list(NULL,
    ##                         c("Version", "Date", "Category", "Text"))
    colnames(out) <- c("Version", "Date", "Category", "Text")
    if(!is.null(bad))
        attr(out, "bad") <- bad
    class(out) <- unique(c(classes, "news_db", "data.frame"))
    out
}

## Transform NEWS.Rd

Rd2txt_NEWS_in_Rd_options <-
    list(sectionIndent = 0L, sectionExtra = 2L,
         minIndent = 4L, code_quote = FALSE,
         underline_titles = FALSE)

Rd2txt_NEWS_in_Rd <-
function(f, out = "") {
    if (grepl("[.]rds$", f)) f <- readRDS(f)
    Rd2txt(f, out,
           stages = c("install", "render"),
           outputEncoding = if(l10n_info()[["UTF-8"]]) "" else "ASCII//TRANSLIT",
           options = Rd2txt_NEWS_in_Rd_options)
 }

Rd2HTML_NEWS_in_Rd <-
function(f, out, ...) {
    if (grepl("[.]rds$", f)) f <- readRDS(f)
    Rd2HTML(f, out, stages = c("install", "render"), ...)
}

Rd2pdf_NEWS_in_Rd <-
function(f, pdf_file)
{
    if (grepl("[.]rds$", f)) f <- readRDS(f)
    f2 <- tempfile()
    ## See the comments in ?texi2dvi about spaces in paths
    f3 <- if(grepl(" ", td <- Sys.getenv("TMPDIR")))
        file.path("/tmp", "NEWS.tex")
    else
        file.path(tempdir(), "NEWS.tex")
    out <- file(f3, "w")
    Rd2latex(f, f2,
             stages = c("install", "render"),
             outputEncoding = "UTF-8", writeEncoding = FALSE)
    cat("\\documentclass[", Sys.getenv("R_PAPERSIZE"), "paper]{book}\n",
        "\\usepackage[ae,hyper]{Rd}\n",
        "\\usepackage[utf8]{inputenc}\n",
        "\\usepackage{graphicx}\n",
        "\\setkeys{Gin}{width=0.7\\textwidth}\n",
        "\\graphicspath{{", normalizePath(file.path(R.home("doc"), "html"), "/"),
                            "/}}\n",
        "\\hypersetup{pdfpagemode=None,pdfstartview=FitH}\n",
        "\\begin{document}\n",
        "\\chapter*{}\\sloppy\n",
        "\\begin{center}\n\\huge\n",
        "NEWS for ", R.version$version.string, "\n",
        "\\end{center}\n",
        sep = "", file = out)
    writeLines(readLines(f2), out)
    writeLines("\\end{document}", out)
    close(out)
    od <- setwd(dirname(f3))
    on.exit(setwd(od))
    texi2pdf("NEWS.tex", quiet = TRUE)
    setwd(od); on.exit()
    invisible(file.copy(file.path(dirname(f3), "NEWS.pdf"),
                        pdf_file, overwrite = TRUE))
}

## Transform old-style plain text NEWS file to Rd.

news2Rd <-
function(file, out = stdout(), codify = FALSE)
{
    ## For add-on packages, the given NEWS file should be in the root
    ## package source directory or its 'inst' subdirectory, so that we
    ## can use the DESCRIPTION metadata to obtain the package name and
    ## encoding.

    file <- file_path_as_absolute(file)
    dir <- dirname(file)
    format <- "default"
    if(file_test("-f", dfile <- file.path(dir, "DESCRIPTION")))
        meta <- .read_description(dfile)
    else if(basename(dir) == "inst" &&
            file_test("-f", dfile <- file.path(dirname(dir),
                                               "DESCRIPTION")))
        meta <- .read_description(dfile)
    else
        format <- "R"

    wto <- function(x) writeLines(x, con = out, useBytes = TRUE)
    cre <- "(\\W|^)(\"[[:alnum:]_.]*\"|[[:alnum:]_.:]+\\(\\))(\\W|$)"

    if(is.character(out)) {
        out <- file(out, "wt")
        on.exit(close(out))
    }
    if(!isOpen(out, "wt")) {
        open(out, "wt")
        on.exit(close(out))
    }

    if(format == "R") {
        news <- readNEWS(chop = "keepAll")
        if(!length(news))
            stop("No news found in given file using old-style R-like format.")
        wto(c("\\newcommand{\\PR}{\\Sexpr[results=rd]{tools:::Rd_expr_PR(#1)}}",
              "\\name{NEWS}",
              "\\title{R News}",
              "\\encoding{UTF-8}"))
        for(y in news) {
            for(i in seq_along(y)) {
                wto(sprintf("\\section{CHANGES IN R VERSION %s}{",
                            names(y)[i]))
                z <- y[[i]]
                for(j in seq_along(z)) {
                    wto(c(sprintf("  \\subsection{%s}{", names(z)[j]),
                          "    \\itemize{"))
                    for(chunk in z[[j]]) {
                        chunk <- toRd(paste(chunk, collapse = "\n      "))
                        if(codify) {
                            chunk <- gsub(cre, "\\1\\\\code{\\2}\\3",
                                          chunk)
                        }
                        chunk <- gsub("PR#([[:digit:]]+)", "\\\\PR{\\1}",
                                      chunk)
                        wto(paste("      \\item", enc2utf8(chunk)))
                    }
                    wto(c("    }", "  }"))
                }
                wto("}")
            }
        }
    } else {
        news <- .news_reader_default(file)
        bad <- attr(news, "bad")
        if(!length(bad))
            stop("No news found in given file using package default format.")
        if(any(bad)) {
            bad <- news$Text[bad]
            stop("Could not extract news from the following text chunks:\n",
                 paste(sprintf("\nChunk %s:\n%s",
                               format(seq_along(bad)), bad),
                       collapse = "\n"))
        }

        encoding <- meta["Encoding"]
        package <- meta["Package"]

        texts <- toRd(news$Text)
        if(codify)
            texts <- gsub(cre, "\\1\\\\code{\\2}\\3", texts)
        ## Note that .news_reader_default re-encodes ...
        if(!is.na(encoding))
            texts <- iconv(texts, to = encoding, sub = "byte", mark = FALSE)
        news$Text <- texts

        wto(c("\\name{NEWS}",
              sprintf("\\title{News for Package '%s'}", package)))
        if(!is.na(encoding))
            wto(sprintf("\\encoding{%s}", encoding))

        ## Similar to print.news_db():
        vchunks <- split(news, news$Version)
        ## Re-order according to decreasing version.
        vchunks <- vchunks[order(as.numeric_version(names(vchunks)),
                                 decreasing = TRUE)]
        dates <- sapply(vchunks, function(v) v$Date[1L])
        if(any(ind <- !is.na(dates)))
            names(vchunks)[ind] <-
                sprintf("%s (%s)", names(vchunks)[ind], dates[ind])
        vheaders <- sprintf("\\section{Changes in %s version %s}{",
                            package, names(vchunks))
        for(i in seq_along(vchunks)) {
            wto(vheaders[i])
            vchunk <- vchunks[[i]]
            if(all(!is.na(category <- vchunk$Category)
                   & nzchar(category))) {
                ## need to preserve order of headings.
                cchunks <-
                    split(vchunk,
                          factor(category, levels = unique(category)))
                cheaders <- sprintf("  \\subsection{%s}{",
                                    names(cchunks))
                for(j in seq_along(cchunks)) {
                    wto(c(cheaders[j],
                          "    \\itemize{",
                          paste("      \\item",
                                gsub("\n", "\n        ",
                                     cchunks[[j]]$Text)),
                          "    }",
                          "  }"))
                }
            } else {
                wto(c("  \\itemize{",
                      paste("    \\item",
                            gsub("\n", "\n      ", vchunk$Text)),
                      "  }"))
            }
            wto("}")
        }
    }
}

Rd_expr_PR <-
function(x)
{
    baseurl <- "https://bugs.R-project.org/bugzilla3/show_bug.cgi?id"
    sprintf("\\href{%s=%s}{PR#%s}", baseurl, x, x)
}

.build_news_db_from_R_NEWS_Rd <-
function(file = NULL)
{
    x <- if(is.null(file))
        readRDS(file.path(R.home("doc"), "NEWS.rds"))
    else {
        ## Expand \Sexpr et al now because this does not happen when using
        ## fragments.
        prepare_Rd(parse_Rd(file), stages = "install")
    }

    db <- .extract_news_from_Rd(x)
    db <- db[db[,1L] != "CHANGES in previous versions",,drop = FALSE]
    
    ## Squeeze in an empty date column.
    .make_news_db(cbind(sub("^CHANGES IN (R )?(VERSION )?", "", db[, 1L]),
                        NA_character_,
                        db[, 2L],
                        sub("\n*$", "", db[, 3L])),
                  logical(nrow(db)),
                  "news_db_from_Rd")
}

.build_news_db_from_package_NEWS_Rd <-
function(file)
{
    x <- prepare_Rd(parse_Rd(file), stages = "install")

    db <- .extract_news_from_Rd(x)

    ## Post-process section names to extract versions and dates.
    re_v <- sprintf(".*version[[:space:]]+(%s).*$",
                    .standard_regexps()$valid_package_version)
    re_d <- sprintf("^.*(%s)[[:punct:][:space:]]*$",
                    "[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}")

    nms <- db[, 1L]
    ind <- grepl(re_v, nms, ignore.case = TRUE)
    if(!all(ind))
        warning("Cannot extract version info from the following section titles:\n",
                sprintf("  %s", unique(nms[!ind])))
    .make_news_db(cbind(ifelse(ind,
                               sub(re_v, "\\1", nms, ignore.case = TRUE),
                               NA_character_),
                        ifelse(grepl(re_d, nms, perl = TRUE),
                               sub(re_d, "\\1", nms, perl = TRUE),
                               NA_character_),
                        db[, 2L],
                        sub("\n*$", "", db[, 3L])),
                  logical(nrow(db)),
                  "news_db_from_Rd")
}

.extract_news_from_Rd <-
function(x)
{
    .get_Rd_section_names <- function(x)
        sapply(x, function(e) .Rd_get_text(e[[1L]]))

    do_chunk <- function(x) {
        ## Currently, chunks should consist of a single \itemize list
        ## containing the news items.  Notify if there is more than one
        ## such list, and stop if there is none.

        pos <- which(RdTags(x) == "\\itemize")
        if(!length(pos)) {
            stop(gettextf("Malformed NEWS.Rd file:\nChunk starting\n  %s\ncontains no \\itemize.",
                          substring(sub("^[[:space:]]*", "",
                                        .Rd_deparse(x)),
                                    1L, 60L)),
                 domain = NA)
        } else if(length(pos) > 1L) {
            warning(gettextf("Malformed NEWS.Rd file:\nChunk starting\n  %s\ncontains more than one \\itemize.\nUsing the first one.",
                             substring(sub("^[[:space:]]*", "",
                                           .Rd_deparse(x)),
                                       1L, 60L)),
                    domain = NA)
            pos <- pos[1L]
        }
        x <- x[pos]

        out <- NULL
        zz <- textConnection("out", "w", local = TRUE)
        on.exit(close(zz))
        Rd2txt(x, out = zz, fragment = TRUE,
               options =
               c(Rd2txt_NEWS_in_Rd_options,
                 list(itemBullet = "\036  ")))

        ## Try to find the column offset of the top-level bullets.
        pat <- "^( *)\036.*"
        off <- min(nchar(sub(pat, "\\1", out[grepl(pat, out)])))
        pat <- sprintf("^%s\036 ",
                       paste(rep.int(" ", off), collapse = ""))
        s <- sub(pat, "\036", out)
        ## Try to remove some indent for nested material.
        pat <- sprintf("^%s",
                       paste(rep.int(" ", off + 2L), collapse = ""))
        s <- sub(pat, "", s)

        s <- paste(s, collapse = "\n")
        s <- sub("^[[:space:]]*\036", "", s)
        s <- sub("[[:space:]]*$", "", s)
        ## <FIXME>
        ## Could be more fancy and use \u2022 "if possible".
        gsub("\036", "*", unlist(strsplit(s, "\n\036", fixed = TRUE)))
        ## </FIXME>
    }

    y <- x[RdTags(x) == "\\section"]
    do.call(rbind,
            Map(cbind,
                .get_Rd_section_names(y),
                lapply(y,
                       function(e) {
                           z <- e[[2L]]
                           ind <- RdTags(z) == "\\subsection"
                           if(any(ind)) {
                               z <- z[ind]
                               do.call(rbind,
                                       Map(cbind,
                                           .get_Rd_section_names(z),
                                           lapply(z,
                                                  function(e)
                                                  do_chunk(e[[2L]]))))
                           } else {
                               cbind(NA_character_, do_chunk(z))
                           }
                       })))

}
#  File src/library/tools/R/package.dependencies.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2012 The R 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 of the License, 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/

## This is called only with check = FALSE in getDepMtrx/getRemotePkgDepends

package.dependencies <-
    function(x, check = FALSE, depLevel = c("Depends", "Imports", "Suggests"))
{
    depLevel <- match.arg(depLevel)

    if(!is.matrix(x))
        x <- matrix(x, nrow = 1L, dimnames = list(NULL, names(x)))

    deps <- list()
    for(k in 1L:nrow(x)){
        z <- x[k, depLevel]
        if(!is.na(z) & z != ""){
            ## split dependencies, remove leading and trailing whitespace
            z <- unlist(strsplit(z, ",", fixed=TRUE))
            z <- sub("^[[:space:]]*(.*)", "\\1", z)
            z <- sub("(.*)[[:space:]]*$", "\\1", z)

            ## split into package names and version
            pat <- "^([^\\([:space:]]+)[[:space:]]*\\(([^\\)]+)\\).*"
            deps[[k]] <-
                cbind(sub(pat, "\\1", z), sub(pat, "\\2", z), NA)

            noversion <- deps[[k]][,1] == deps[[k]][,2]
            deps[[k]][noversion,2] <- NA

            ## split version dependency into operator and version number
            pat <- "[[:space:]]*([[<>=]+)[[:space:]]+(.*)"
            deps[[k]][!noversion, 2:3] <-
                c(sub(pat, "\\1", deps[[k]][!noversion, 2]),
                  sub(pat, "\\2", deps[[k]][!noversion, 2]))
        }
        else
            deps[[k]] <- NA
    }

    if(check){
        z <- rep.int(TRUE, nrow(x))
        for(k in 1L:nrow(x)) {
            ## currently we only check the version of R itself
            if(!is.na(deps[[k]]) &&
               any(ok <- deps[[k]][,1] == "R")) {
                ## NOTE: currently operators must be `<=' or `>='.
                if(!is.na(deps[[k]][ok, 2])
                   && deps[[k]][ok, 2] %in% c("<=", ">=")) {
                    ## careful.  We don't want 1.9.1 < 1.50
                    op <- deps[[k]][ok,2]
                    x1 <- rep.int(0, 6)
                    y <- c(R.version$major,
                           strsplit(R.version$minor, ".", fixed=TRUE)[[1L]])
                    x1[seq_along(y)] <- y
                    y <- strsplit(deps[[k]][ok,3], ".", fixed=TRUE)[[1L]]
                    x1[3+seq_along(y)] <- y
                    x1 <- format(x1, justify="right")
                    x2 <- paste(x1[4:6], collapse=".")
                    x1 <- paste(x1[1L:3], collapse=".")
                    comptext <- paste0("'", x1, "' ", op, " '", x2, "'")
                    compres <- try(eval(parse(text = comptext)))
                    if(!inherits(compres, "try-error")) {
                        z[k] <- compres
                    }
                }
            }
        }
        names(z) <- x[,"Package"]
        return(z)
    }
    else{
        names(deps) <- x[,"Package"]
        return(deps)
    }
}
#  File src/library/tools/R/writePACKAGES.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/

write_PACKAGES <-
function(dir = ".", fields = NULL,
         type = c("source", "mac.binary", "win.binary"),
         verbose = FALSE, unpacked = FALSE, subdirs = FALSE,
         latestOnly = TRUE, addFiles = FALSE)
{
    if(missing(type) && .Platform$OS.type == "windows")
        type <- "win.binary"
    type <- match.arg(type)
    nfields <- 0
    out <- file(file.path(dir, "PACKAGES"), "wt")
    outgz <- gzfile(file.path(dir, "PACKAGES.gz"), "wt")

    paths <- ""
    if(is.logical(subdirs) && subdirs) {
        owd <- setwd(dir)
        paths <- list.dirs(".")
        setwd(owd)
        paths <- c("", paths[paths != "."])
    } else if(is.character(subdirs)) paths <- c("", subdirs)

    for(path in paths) {
        this <- if(nzchar(path)) file.path(dir, path) else dir
        desc <- .build_repository_package_db(this, fields, type, verbose,
                                             unpacked)

        if(length(desc)) {
            Files <- names(desc)
            fields <- names(desc[[1L]])
            desc <- matrix(unlist(desc), ncol = length(fields), byrow = TRUE)
            colnames(desc) <- fields
            if(addFiles) desc <- cbind(desc, File = Files)
            if(latestOnly) desc <- .remove_stale_dups(desc)

            ## Standardize licenses or replace by NA.
            license_info <- analyze_licenses(desc[, "License"])
            desc[, "License"] <-
                ifelse(license_info$is_standardizable,
                       license_info$standardization,
                       NA)

            ## Writing PACKAGES file from matrix desc linewise in order to
            ## omit NA entries appropriately:
            for(i in seq_len(nrow(desc))){
                desci <- desc[i, !(is.na(desc[i, ]) | (desc[i, ] == "")),
                              drop = FALSE]
                write.dcf(desci, file = out)
                if(nzchar(path)) cat("Path: ", path, "\n", sep = "", file = out)
                cat("\n", file = out)
                write.dcf(desci, file = outgz)
                if(nzchar(path)) cat("Path: ", path, "\n", sep = "", file = outgz)
                cat("\n", file = outgz)
            }
            nfields <- nfields + nrow(desc)
        }
    }

    close(out)
    close(outgz)
    invisible(nfields)
}

## this is OK provided all the 'fields' are ASCII -- so be careful
## what you add.
.build_repository_package_db <-
function(dir, fields = NULL,
         type = c("source", "mac.binary", "win.binary"),
         verbose = getOption("verbose"),
         unpacked = FALSE)
{
    if(unpacked)
        return(.build_repository_package_db_from_source_dirs(dir,
                                                             fields,
                                                             verbose))

    type <- match.arg(type)

    ## FIXME: might the source pattern be more general?
    ## was .tar.gz prior to 2.10.0
    package_pattern <- switch(type,
                              "source" = "_.*\\.tar\\..*$",
                              "mac.binary" = "_.*\\.tgz$",
                              "win.binary" = "_.*\\.zip$")
    files <- list.files(dir, pattern = package_pattern)

    if(!length(files))
        return(list())

    ## Add the standard set of fields required to build a repository's
    ## PACKAGES file:
    fields <- unique(c(.get_standard_repository_db_fields(type), fields))
    packages <- sapply(strsplit(files, "_", fixed = TRUE), "[", 1L)
    db <- vector(length(files), mode = "list")
    names(db) <- files
    ## Many (roughly length(files)) warnings are *expected*, hence
    ## suppressed.
    op <- options(warn = -1)
    on.exit(options(op))
    if(verbose) message("Processing packages:")
    if(type == "win.binary") {
        files <- file.path(dir, files)
        for(i in seq_along(files)) {
            if(verbose) message(paste(" ", files[i]))
            con <- unz(files[i], file.path(packages[i], "DESCRIPTION"))
            temp <- tryCatch(read.dcf(con, fields = fields)[1L, ],
                             error = identity)
            if(inherits(temp, "error")) {
                close(con)
                next
            }
            db[[i]] <- temp
            close(con)
        }
    } else {
        dir <- file_path_as_absolute(dir)
        files <- file.path(dir, files)
        cwd <- getwd()
        if (is.null(cwd))
            stop("current working directory cannot be ascertained")
        td <- tempfile("PACKAGES")
        if(!dir.create(td)) stop("unable to create ", td)
        on.exit(unlink(td, recursive = TRUE), add = TRUE)
        setwd(td)
        for(i in seq_along(files)) {
            if(verbose) message(paste(" ", files[i]))
            p <- file.path(packages[i], "DESCRIPTION")
            ## temp <- try(system(paste("tar zxf", files[i], p)))
            temp <- try(utils::untar(files[i], files = p))
            if(!inherits(temp, "try-error")) {
                temp <- tryCatch(read.dcf(p, fields = fields)[1L, ],
                                 error = identity)
                if(!inherits(temp, "error")) {
                    if(is.na(temp["NeedsCompilation"])) {
                        l <- utils::untar(files[i], list = TRUE)
                        temp["NeedsCompilation"] <-
                            if(any(l == file.path(packages[i], "src/"))) "yes" else "no"
                    }
                    temp["MD5sum"] <- md5sum(files[i])
                    db[[i]] <- temp
                }
            }
            unlink(packages[i], recursive = TRUE)
        }
        setwd(cwd)
    }
    if(verbose) message("done")

    db
}

.build_repository_package_db_from_source_dirs <-
function(dir, fields = NULL, verbose = getOption("verbose"))
{
    dir <- file_path_as_absolute(dir)
    fields <- unique(c(.get_standard_repository_db_fields(), fields))
    paths <- list.files(dir, full.names = TRUE)
    paths <- paths[file_test("-d", paths) &
                   file_test("-f", file.path(paths, "DESCRIPTION"))]
    db <- vector(length(paths), mode = "list")
    if(verbose) message("Processing packages:")
    for(i in seq_along(paths)) {
        if(verbose) message(paste(" ", basename(paths[i])))
        temp <- tryCatch(read.dcf(file.path(paths[i], "DESCRIPTION"),
                                  fields = fields)[1L, ],
                         error = identity)
        if(!inherits(temp, "error")) {
            if(is.na(temp["NeedsCompilation"])) {
                temp["NeedsCompilation"] <-
                    if(file_test("-d", file.path(paths[i], "src"))) "yes" else "no"
            }
            ## Cannot compute MD5 sum of the source tar.gz when working
            ## on the unpacked sources ...
            db[[i]] <- temp
        }
    }
    if(verbose) message("done")
    names(db) <- basename(paths)
    db
}

dependsOnPkgs <-
function(pkgs, dependencies = c("Depends", "Imports", "LinkingTo"),
         recursive = TRUE, lib.loc = NULL,
         installed = installed.packages(lib.loc, fields = "Enhances"))
{
    if(identical(dependencies, "all"))
        dependencies <-
            c("Depends", "Imports", "LinkingTo", "Suggests", "Enhances")
    else if(identical(dependencies, "most"))
        dependencies <-
            c("Depends", "Imports", "LinkingTo", "Suggests")

    av <- installed[, dependencies, drop = FALSE]
    rn <- row.names(installed)
    need <- apply(av, 1L, function(x)
                  any(pkgs %in% utils:::.clean_up_dependencies(x)) )
    uses <- rn[need]
    if(recursive) {
        p <- pkgs
        repeat {
            p <- unique(c(p, uses))
            need <- apply(av, 1L, function(x)
                          any(p %in% utils:::.clean_up_dependencies(x)) )
            uses <- unique(c(p, rn[need]))
            if(length(uses) <= length(p)) break
        }
    }
    setdiff(uses, pkgs)
}

.remove_stale_dups <-
function(ap)
{
    ## Given a matrix from available.packages, return a copy
    ## with no duplicate packages, being sure to keep the packages
    ## with highest version number.
    ## (Also works for data frame package repository dbs.)
    pkgs <- ap[ , "Package"]
    dup_pkgs <- pkgs[duplicated(pkgs)]
    stale_dups <- integer(length(dup_pkgs))
    i <- 1L
    for (dp in dup_pkgs) {
        wh <- which(dp == pkgs)
        vers <- package_version(ap[wh, "Version"])
        keep_ver <- max(vers)
	keep_idx <- which.max(vers == keep_ver) # they might all be max
        wh <- wh[-keep_idx]
        end_i <- i + length(wh) - 1L
        stale_dups[i:end_i] <- wh
        i <- end_i + 1L
    }
    ## Possible to have only one package in a repository
    if(length(stale_dups)) ap[-stale_dups, , drop = FALSE] else ap
}

package_dependencies <-
function(packages = NULL, db,
         which = c("Depends", "Imports", "LinkingTo"),
         recursive = FALSE, reverse = FALSE)
{
    ## <FIXME>
    ## What about duplicated entries?
    ## </FIXME>

    ## For given packages which are not found in the db, return "list
    ## NAs" (i.e., NULL entries), as opposed to character() entries
    ## which indicate no dependencies.

    ## For forward non-recursive depends, we can simplify matters by
    ## subscripting the db right away---modulo boundary cases.

    out_of_db_packages <- character()
    if(!recursive && !reverse) {
        if(!is.null(packages)) {
            ind <- match(packages, db[, "Package"], nomatch = 0L)
            db <- db[ind, , drop = FALSE]
            out_of_db_packages <- packages[ind == 0L]
        }
    }

    if(identical(which, "all"))
        which <-
            c("Depends", "Imports", "LinkingTo", "Suggests", "Enhances")
    else if(identical(which, "most"))
        which <-
            c("Depends", "Imports", "LinkingTo", "Suggests")

    depends <-
        do.call(Map,
                c(list("c"),
                  ## Try to make this work for dbs which are character
                  ## matrices as from available.packages(), or data
                  ## frame variants thereof.
                  lapply(which,
                         function(f) {
                             if(is.list(d <- db[, f])) d
                             else lapply(d,
                                         .extract_dependency_package_names)
                         }),
                  list(USE.NAMES = FALSE)))

    depends <- lapply(depends, unique)

    if(!recursive && !reverse) {
        names(depends) <- db[, "Package"]
        if(length(out_of_db_packages)) {
            depends <-
                c(depends,
                  structure(vector("list", length(out_of_db_packages)),
                            names = out_of_db_packages))
        }
        return(depends)
    }

    all_packages <- sort(unique(c(db[, "Package"], unlist(depends))))

    if(!recursive) {
        ## Need to invert.
        depends <-
            split(rep.int(db[, "Package"], sapply(depends, length)),
                  factor(unlist(depends), levels = all_packages))
        if(!is.null(packages)) {
            depends <- depends[match(packages, names(depends))]
            names(depends) <- packages
        }
        return(depends)
    }

    ## Recursive dependencies.
    ## We need to compute the transitive closure of the dependency
    ## relation, but e.g. Warshall's algorithm (O(n^3)) is
    ## computationally infeasible.
    ## Hence, in principle, we do the following.
    ## Take the current list of pairs (i,j) in the relation.
    ## Iterate over all j and whenever i R j and j R k add (i,k).
    ## Repeat this until no new pairs get added.
    ## To do this in R, we use a 2-column matrix of (i,j) rows.
    ## We then create two lists which for all j contain the i and k
    ## with i R j and j R k, respectively, and combine these.
    ## This works reasonably well, but of course more efficient
    ## implementations should be possible.
    tab <- if(reverse)
        split(match(rep.int(db[, "Package"],
                            sapply(depends, length)),
                    all_packages),
              factor(match(unlist(depends), all_packages),
                     levels = seq_along(all_packages)))
    else
        split(match(unlist(depends), all_packages),
              factor(match(rep.int(db[, "Package"],
                                   sapply(depends, length)),
                           all_packages),
                     levels = seq_along(all_packages)))
    if(is.null(packages)) {
        if(reverse) {
            packages <- all_packages
            p_L <- seq_along(all_packages)
        } else {
            packages <- db[, "Package"]
            p_L <- match(packages, all_packages)
        }
    } else {
        p_L <- match(packages, all_packages, nomatch = 0L)
        if(any(ind <- (p_L == 0L))) {
            out_of_db_packages <- packages[ind]
            packages <- packages[!ind]
            p_L <- p_L[!ind]
        }
    }
    p_R <- tab[p_L]
    pos <- cbind(rep.int(p_L, sapply(p_R, length)), unlist(p_R))
    ctr <- 1L
    verbose <- getOption("verbose")
    repeat {
        if(verbose) cat("Cycle:", ctr)
        p_L <- split(pos[, 1L], pos[, 2L])
        new <- do.call(rbind,
                       Map(function(i, k)
                           cbind(rep.int(i, length(k)),
                                     rep(k, each = length(i))),
                           p_L, tab[as.integer(names(p_L))]))
        npos <- unique(rbind(pos, new))
        nnew <- nrow(npos) - nrow(pos)
        if(verbose) cat(" NNew:", nnew, "\n")
        if(!nnew) break
        pos <- npos
        ctr <- ctr + 1L
    }
    depends <-
        split(all_packages[pos[, 2L]],
              factor(all_packages[pos[, 1L]],
                     levels = unique(packages)))
    if(length(out_of_db_packages)) {
        depends <-
            c(depends,
              structure(vector("list", length(out_of_db_packages)),
                        names = out_of_db_packages))
    }
    depends
}


.package_dependencies <- function(packages = NULL, db,
         which = c("Depends", "Imports", "LinkingTo"),
         recursive = FALSE, reverse = FALSE)
{
    .Deprecated("package_dependencies")
    package_dependencies(packages = packages, db = db,
         which = which, recursive = recursive, reverse = reverse)
}

.extract_dependency_package_names <-
function(x) {
    ## Assume a character *string*.
    if(is.na(x)) return(character())
    x <- unlist(strsplit(x, ",[[:space:]]*"))
    x <- sub("[[:space:]]*([[:alnum:].]+).*", "\\1", x)
    x[nzchar(x) & (x != "R")]
}
#  File src/library/tools/R/parseLatex.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2012 The R 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 of the License, 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/

## this is called during package installation via makeLatex()
parseLatex <- function(text, filename = deparse(substitute(text)),
                     verbose = FALSE, verbatim = c("verbatim", "verbatim*",
                     "Sinput", "Soutput") )
{
    ## the internal function must get some sort of srcfile
    srcfile <- srcfilecopy(filename, text, file.info(filename)[1,"mtime"])
    text <- paste(text, collapse="\n")
    .External2("C_parseLatex", text, srcfile, verbose, as.character(verbatim),
               PACKAGE = "tools")
}


# This converts a latex object into a single element character vector
deparseLatex <- function(x, dropBraces = FALSE)
{
    result <- character()
    lastTag <- "TEXT"
    for (i in seq_along(x)) {
        a <- x[[i]]
        tag <- attr(a, "latex_tag")
        if (is.null(tag)) tag <- "NULL"
        switch(tag,
        VERB = ,
        TEXT = ,
        MACRO = ,
        COMMENT = result <- c(result, a),
        BLOCK = result <- c(result, if (dropBraces && lastTag == "TEXT") deparseLatex(a) else c("{", deparseLatex(a), "}")),
        ENVIRONMENT = result <- c(result,
        	"\\begin{", a[[1L]], "}",
        	deparseLatex(a[[2L]]),
        	"\\end{", a[[1L]], "}"),
        MATH = result <- c(result, "$", deparseLatex(a), "$"),
        NULL = stop("Internal error, no tag", domain = NA)
        )
        lastTag <- tag
    }
    paste(result, collapse="")
}

print.LaTeX <- function(x, ...) cat(deparseLatex(x), "\n")

latex_tag <- function(x, tag)
{
    if (!is.null(x)) attr(x, "latex_tag") <- tag
    x
}

# This makes substitutions within a latex object to replace latex characters
# with UTF8 characters where possible.
latexToUtf8 <- function(x)
{
    i <- 0L
    whitespace <- c(' ', '\t', '\n')
    while (i < length(x)) {
    	i <- i + 1L
        a <- x[[i]]
        tag <- attr(a, "latex_tag")
        if (tag == "MACRO") {
            numargs <- latexArgCount[a]
            if (!is.na(numargs)) { # Do we know this macro?
		args <- vector("list", numargs)
		j <- i
		getNext <- TRUE
		k <- 1L
		while (k <= numargs) {
		    if (getNext) {
			j <- j + 1L
			if (j > length(x)) {
			    warning("argument for ", c(a), " not found", domain = NA)
			    nextobj <- latex_tag("", "TEXT")
			    nexttag <- "TEXT"
			    nextchars <- ""
			} else {
			    nextobj <- x[[j]]
			    nexttag <- attr(nextobj, "latex_tag")
			    if (nexttag == "TEXT")
				nextchars <- strsplit(nextobj, "")[[1L]]
			}
			getNext <- FALSE
		    }
		    switch(nexttag,
			TEXT = {
			    args[[k]] <- latex_tag(nextchars[1L], "TEXT")
			    nextchars <- nextchars[-1L]
			    if (!length(nextchars)) getNext <- TRUE
			    if (args[[k]] %in% whitespace) next
			    k <- k+1L
			},
			COMMENT = getNext <- TRUE, # strip comments
			BLOCK =,
			ENVIRONMENT =,
			MATH = {
			    args[[k]] <- latexToUtf8(nextobj)
			    k <- k+1L
			    getNext <- TRUE
			},
			NULL = stop("Internal error:  NULL tag", domain = NA))
		}
		index <- a
		for (i1 in seq_along(args)) {
		    if (is.null(latexTable[[index]])) break
		    nextobj1 <- args[[i1]]
		    nexttag1 <- attr(nextobj1, "latex_tag")
		    index <- c(index, switch(nexttag1,
			    MACRO =,
			    TEXT = nextobj1,
			    BLOCK = deparseLatex(nextobj1, dropBraces=TRUE)))
		}
		subst <- latex_tag(latexTable[[index]], "TEXT")

		if (!is.null(subst) && !is.list(subst)) { # We've made a substitution, which will always
		  	       	       # be a new latex object, possibly containing UTF8
		    x[[i]] <- subst

		    if (numargs) {
		    	if (nexttag == "TEXT" && length(nextchars)) {
		    	    # We've partially used up the next one, so rebuild it
			    nextobj[1L] <- paste(nextchars, collapse="")
			    x[[j]] <- nextobj
			    j <- j-1L
			}
			while (j > i) {
			    # Remove the used up args
			    x[[j]] <- NULL
			    j <- j-1L
			}
	            }
		} else
		    i <- j
	    }
	} else if (tag == "BLOCK")
	    x[[i]] <- latexToUtf8(a)
    }
    x
}

makeLatexTable <- function(utf8table)
{
    all <- list()
    for (i in seq_along(utf8table)) {
    	if (grepl("^[{].*[}]$", c <- utf8table[i]))
    	    all[[as.character(i)]] <- parseLatex(c)[[1L]]
    }
    table <- list()
    for (i in names(all)) {
    	codepoint <- as.numeric(i)
    	macro <- all[[i]][[1L]]
    	args <- all[[i]][-1L]
    	index <- macro
    	getNext <- TRUE
    	repeat {
	    if (getNext) {
	    	if (!length(args)) break
		nextobj <- args[[1L]]
		args <- args[-1L]
		nexttag <- attr(nextobj, "latex_tag")
		if (nexttag == "TEXT")
		    nextchars <- strsplit(nextobj, "")[[1L]]
		else
		    nextchars <- character()
		getNext <- FALSE
	    }
    	    if (nexttag == "TEXT") {
    	    	if (length(nextchars)) {
    	    	    arg <- nextchars[1L]
    	    	    nextchars <- nextchars[-1L]
    	    	} else {
    	    	    getNext <- TRUE
    	    	    next
    	    	}
    	    } else if (nexttag == "BLOCK") {
    	    	if (!length(nextobj)) {
    	    	    arg <- ""   # or character()?
    	    	    getNext <- TRUE
    	    	} else {
    	    	    arg <- nextobj[[1L]]
    	    	    nextobj <- nextobj[-1L]
    	    	    argtag <- attr(arg, "latex_tag")
    	    	    if (argtag != "TEXT")
    	    	    	stop("internal error", domain = NA)
    	    	}
    	    } else if (nexttag == "MACRO") {
    	    	arg <- nextobj[1L]
    	    	getNext <- TRUE
    	    }
    	    index <- c(index, arg)
    	}
    	repeat{  # Need to record \a macros twice
	    oldArgCount <- latexArgCount[macro]
	    argCount <- length(index) - 1L
	    if (is.na(oldArgCount))
		latexArgCount[macro] <<- argCount
	    else if (oldArgCount != length(index) - 1L)
    	    stop("Inconsistent arg count for ", macro, domain = NA)

	    for (i in seq_along(index)) {
		if (is.null(entry <- table[[index[1L:i]]])) {
		    if (i < length(index))
			table[[index[1L:i]]] <- list()
		    else
			table[[index]] <- intToUtf8(codepoint)
		} else if (!is.list(entry))
		    warning("entry for ", codepoint, "=", index[1L:i], " already defined to be", entry, domain = NA)
	    }
	    if (index[1L] != "\\a") break
	    index <- index[-1L]
	    index[1L] <- macro <- sub("^", "\\\\", index[1L])
	}
    }
    table
}
#  File src/library/tools/R/parseRd.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2012 The R 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 of the License, 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/

parse_Rd <- function(file, srcfile = NULL, encoding = "unknown",
                     verbose = FALSE, fragment = FALSE,
                     warningCalls = TRUE)
{
    if(is.character(file)) {
        file0 <- file
        if(file == "") {
            file <- stdin()
        } else {
            ## keep.source is FALSE in batch use
            ## encoding issues here, for now use file encoding
            if (missing(srcfile)) ## && isTRUE(getOption("keep.source")))
                srcfile <- srcfile(file)
        }
    } else file0 <- "<connection>"
    lines <- readLines(file, warn = FALSE)
    ## remove old-style marking for data, keep line nos
    lines[lines == "\\non_function{}"] <- ""
    ## Extract the encoding if marked in the file:
    ## do this in two steps to minimize warnings in MBCS locales
    ## Note this is required to be on a line by itself,
    ## but some people have preceding whitespace
    enc <- grep("\\encoding{", lines, fixed = TRUE, useBytes=TRUE)
    enc <- grep("^[[:space:]]*\\\\encoding\\{([^}]*)\\}.*", lines[enc], value=TRUE)
    if(length(enc)) {
        if(length(enc) > 1L)
            warning(file0, ": multiple \\encoding lines, using the first",
                    domain = NA, call. = warningCalls)
        ## keep first one
        enc <- enc[1L]
        enc <- sub("^[[:space:]]*\\\\encoding\\{([^}]*)\\}.*", "\\1", enc)
        if(verbose) message("found encoding ", enc, domain = NA)
        encoding <- if(enc %in% c("UTF-8", "utf-8", "utf8")) "UTF-8" else enc
    }
    if (encoding == "unknown") encoding <- ""

    ## the internal function must get some sort of srcfile
    if (!inherits(srcfile, "srcfile"))
    	srcfile <- srcfile(file0)
    basename <- basename(srcfile$filename)
    srcfile$encoding <- encoding
    srcfile$Enc <- "UTF-8"

    if (encoding == "ASCII") {
        if (any(is.na(iconv(lines, "", "ASCII"))))
            stop(file0, ": non-ASCII input and no declared encoding",
                 domain = NA, call. = warningCalls)
    } else if (encoding != "UTF-8")
    	lines <- iconv(lines, encoding, "UTF-8", sub = "byte")

    tcon <- file()
    writeLines(lines, tcon, useBytes = TRUE)
    on.exit(close(tcon))

    result <- .External2(C_parseRd, tcon, srcfile, "UTF-8",
                         verbose, basename, fragment, warningCalls)
    expandDynamicFlags(result)
}

print.Rd <- function(x, deparse = FALSE, ...)
{
    cat(as.character.Rd(x, deparse = deparse), sep = "", collapse = "")
    invisible(x)
}

as.character.Rd <- function(x, deparse = FALSE, ...)
{
    ZEROARG <- c("\\cr", "\\dots", "\\ldots", "\\R", "\\tab") # Only these cause trouble when {} is added
    TWOARG <- c("\\section", "\\item", "\\enc", "\\method", "\\S3method",
                "\\S4method", "\\tabular")
    USERMACROS <- c("USERMACRO", "\\newcommand", "\\renewcommand")
    EQN <- c("\\deqn", "\\eqn", "\\figure")
    modes <- c(RLIKE = 1L, LATEXLIKE = 2L, VERBATIM = 3L, INOPTION = 4L, COMMENTMODE = 5L, UNKNOWNMODE = 6L)
    tags  <- c(RCODE = 1L, TEXT = 2L,      VERB = 3L,                  COMMENT = 5L,     UNKNOWN = 6L)
    state <- c(braceDepth = 0L, inRString = 0L)
    needBraces <- FALSE  # if next character is alphabetic, separate by braces.
    inEqn <- 0L

    pr <- function(x, quoteBraces) {
        tag <- attr(x, "Rd_tag")
        if (is.null(tag) || tag == "LIST") tag <- ""
    	if (is.list(x)) {
    	    savestate <- state
    	    state <<- c(0L, 0L)
    	    needBraces <<- FALSE
    	    if (tag == "Rd") { # a whole file
    	        result <- character()
    	    	for (i in seq_along(x))
                    result <- c(result, pr(x[[i]], quoteBraces))
    	    } else if (length(grep("^#", tag))) {
    	    	if (deparse) {
    	    	    dep <- deparseRdElement(x[[1L]][[1L]],
                                            c(state, modes["LATEXLIKE"],
                                              inEqn,
                                              as.integer(quoteBraces)))
    	    	    result <- c(tag, dep[[1L]])
    	    	} else
    	    	    result <- c(tag, x[[1L]][[1L]])
    	    	for (i in seq_along(x[[2L]]))
                    result <- c(result, pr(x[[2L]][[i]], quoteBraces))
    	    	result <- c(result, "#endif\n")
    	    } else if (tag %in% ZEROARG) {
    	    	result <- tag
    	    	needBraces <<- TRUE
    	    } else if (tag %in% TWOARG) {
    	    	result <- tag
    	    	for (i in seq_along(x))
                    result <- c(result, pr(x[[i]], quoteBraces))
    	    } else if (tag %in% EQN) {
    	    	result <- tag
    	    	inEqn <<- 1L
    	    	result <- c(result, pr(x[[1L]], quoteBraces))
    	    	inEqn <<- 0L
    	    	if (length(x) > 1L)
    	    	    result <- c(result, pr(x[[2L]], quoteBraces))
    	    } else {
    	    	result <- tag
    	    	if (!is.null(option <- attr(x, "Rd_option")))
    	    	    result <- c(result, "[", pr(option, quoteBraces), "]")
    	    	result <- c(result, "{")
    	    	for (i in seq_along(x))
                    result <- c(result, pr(x[[i]], quoteBraces))
    	    	result <- c(result, "}")
    	    }
    	    if (state[1L])  # If braces didn't match within the list, try again, quoting them
    	    	result <- pr(x, TRUE)
    	    state <<- savestate
    	} else if (tag %in% USERMACROS) {
    	    	result <- c()
    	} else {
    	    if (deparse) {
    		dep <- deparseRdElement(as.character(x), c(state, tags[tag], inEqn, as.integer(quoteBraces)))
    	    	result <- dep[[1L]]
    	    	state <<- dep[[2L]][1L:2L]
    	    } else
    	    	result <- as.character(x)
    	    if (needBraces) {
    	    	if (grepl("^[[:alpha:]]", result)) result <- c("{}", result)
    	    	needBraces <<- FALSE
    	    }
        }
    	result
    }
    if (is.null(attr(x, "Rd_tag"))) attr(x, "Rd_tag") <- "Rd"
    pr(x, quoteBraces = FALSE)
}

deparseRdElement <- function(element, state)
    .Call(C_deparseRd, element, state)
#  File src/library/tools/R/pdftools.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/

## See PDF Reference version 1.7 chapter 3:
##   At the most fundamental level, a PDF file is a sequence of 8-bit
##   bytes.
## where subsequently for chapter 3
##   the term character is synonymous with byte and merely refers to a
##   particular 8-bit value ...
##
## The PDF character set is divided into 3 classes:
## White-space characters (table 3.1):
##    0 00 000 Null (NUL)
##    9 09 011 Tab (HT)
##   10 0A 012 Line feed (LF)
##   12 0C 014 Form feed (FF)
##   13 0D 015 Carriage return (CR)
##   32 20 040 Space (SP)
## Delimiter characters:
##   ( ) < > [ ] { } / %
## All characters except white-space characters and delimiters are
## regular characters.

## * Variables

pdf_bytes_whitespaces <-
    c(charToRaw("\t\n\f\r "), as.raw(0L))
pdf_bytes_delimiters <-
    charToRaw("()<>[]{}/%")
pdf_bytes_non_regulars <-
    c(pdf_bytes_whitespaces, pdf_bytes_delimiters)
pdf_bytes_eols <-
    charToRaw("\n\r")
pdf_bytes_digits <-
    charToRaw("0123456789")

pdf_bytes_in_keywords <-
    charToRaw(paste0("*'\"",
                    "0123456789",
                    paste(LETTERS, collapse = ""),
                    paste(letters, collapse = "")))

pdf_bytes_in_numerics_not_digits <-
    charToRaw("+-.")
pdf_bytes_in_numerics <-
    c(pdf_bytes_digits, pdf_bytes_in_numerics_not_digits)

pdf_page_sizes <-
do.call(rbind,
        list("A0" =        c(2384L, 3371L),
             "A1" =        c(1685L, 2384L),
             "A2" =        c(1190L, 1684L),
             "A3" =        c( 842L, 1190L),
             "A4" =        c( 595L,  842L),
             "A5" =        c( 420L,  595L),
             "B4" =        c( 729L, 1032L),
             "B5" =        c( 516L,  729L),
             "letter" =    c( 612L,  792L),
             "tabloid" =   c( 792L, 1224L),
             "ledger" =    c(1224L,  792L),
             "legal" =     c( 612L, 1008L),
             "statement" = c( 396L,  612L),
             "executive" = c( 540L,  720L),
             "folio" =     c( 612L,  936L),
             "quarto" =    c( 610L,  780L),
             "10x14" =     c( 720L, 1008L)))

## * pdf_doc

pdf_doc <-
function(file, cache = TRUE)
{
    if(is.character(file)) {
        ## <FIXME>
        ## When caching, we could read the whole PDF file into memory
        ## and use a raw connection to read this byte stream.  But is
        ## there a way to get the connection closed when the doc object
        ## gets removed?
        ##   if(cache) {
        ##       .bytes <- readBin(file, "raw", file.info(file)$size)
        ##       con <- rawConnection(.bytes)
        ##       keep <- TRUE
        ##   }
        ## </FIXME>
        con <- file(file, "rb")
        on.exit(close(con))
        keep <- FALSE
    } else if(inherits(file, "rawConnection")) {
        con <- file
        file <- NA_character_
        keep <- TRUE
    } else if(inherits(file, "file")) {
        con <- file
        file <- summary(con)$description
        keep <- TRUE
    } else {
        stop(gettextf("%s must be a character string or a file/raw connection",
                      sQuote("file")),
             domain = NA)
    }

    ## Read header.
    .con_seek(con, 0L)
    header <- rawToChar(read_next_bytes_until_whitespace(con))
    if(substring(header, 1L, 5L) != "%PDF-")
        stop("PDF header not found")

    ## Go to the end.
    .con_seek(con, -1L, 3L)

    ## Record file size as number of bytes.
    nbytes <- .con_seek(con) + 1L

    ## Check footer.
    bytes <- raw()
    while(!length(bytes))
        bytes <- read_prev_bytes_after_eols(con)
    if(rawToChar(bytes) != "%%EOF")
        stop("EOF marker not found")

    ## Find startxref entry (the location of the xref table).
    ## See PDF Reference version 1.7 section 3.4.4:
    ##   The last line of the file contains only the end-of-file marker,
    ##   %%EOF.
    ##   The two preceding lines contain the keyword startxref and the
    ##   byte offset from the beginning of the file to the beginning of
    ##   the xref keyword in the last cross-reference section.
    ## But as of 2011-09-12 there is at least one PDF in CRAN's packages
    ## (limSolve/inst/doc/JSS-373-fig1.pdf) which has keyword and offset
    ## in the same line.
    ## Hence, let's be nice, and read back over any white-space and not
    ## just eols.

    bytes <- read_prev_bytes_after_bytes(con, pdf_bytes_whitespaces)
    startxref <- suppressWarnings(as.integer(rawToChar(bytes)))
    bytes <- read_prev_bytes_after_bytes(con, pdf_bytes_whitespaces)
    if(substring(rawToChar(bytes), 1L, 9L) != "startxref")
        stop("cannot find 'startxref' keyword")

    xref_tabs <-
        matrix(integer(), nrow = 0L, ncol = 4L,
               dimnames = list(NULL, c("num", "pos", "gen", "use")))
    xref_objs <-
        matrix(integer(), nrow = 0L, ncol = 3L,
               dimnames = list(NULL, c("num", "str", "idx")))
    trailer <- list()

    ## Some PDFs have the offset to the xref table wrong.  As of
    ## 2011-08-24,
    ## * gdata/inst/doc/gregmisc.pdf points to the char after the x
    ## * gplots/inst/doc/BalloonPlot.pdf points to after xref
    find_xref_start <- function(con) {
        ## Skip backwards over whitespace, then read back until the next
        ## whitespace.
        .con_seek(con, -1L, 2L)
        repeat {
            x <- .con_read_bytes(con, 1L)
            if(!(x %.IN.% pdf_bytes_whitespaces)) break
            .con_seek(con, -2L, 2L)
        }
        repeat {
            .con_seek(con, -2L, 2L)
            x <- .con_read_bytes(con, 1L)
            if(x %.IN.% pdf_bytes_whitespaces) break
        }
        pos <- .con_seek(con)
        if(rawToChar(.con_read_bytes(con, 4L)) == "xref")
            pos
        else
            stop("cannot find xref table")
    }

    ## Load the xref info.
    repeat {
        .con_seek(con, startxref)
        x <- .con_read_bytes(con, 1L)
        if(x == charToRaw("x")) {
            ## A standard cross-reference table, hopefully.
            bytes <- read_next_bytes_until_whitespace(con)
            if(!rawToChar(bytes) == "ref")
                stop("cannot read xref table")
            read_next_non_whitespace_and_seek_back(con)
            repeat {
                bytes <- read_next_bytes_until_whitespace(con)
                num <- suppressWarnings(as.integer(rawToChar(bytes)))
                read_next_non_whitespace_and_seek_back(con)
                bytes <- read_next_bytes_until_whitespace(con)
                size <- suppressWarnings(as.integer(rawToChar(bytes)))
                read_next_non_whitespace_and_seek_back(con)
                cnt <- 0
                entries <- list()
                while(cnt < size) {
                    bytes <- .con_read_bytes(con, 20L)
                    ## Assume that all lines were correctly at 20 bytes.
                    ## (Could also try to be nice ...)
                    entry <- c(num,
                               as.integer(rawToChar(bytes[ 1L : 10L])),
                               as.integer(rawToChar(bytes[12L : 16L])),
                               bytes[18L] == 0x6e) # charToRaw("n") => 6e
                    entries <- c(entries, list(entry))
                    cnt <- cnt + 1L
                    num <- num + 1L
                }
                xref_tabs <- rbind(xref_tabs, do.call(rbind, entries))
                read_next_non_whitespace_and_seek_back(con)
                if(rawToChar(.con_read_bytes(con, 7L)) != "trailer")
                    .con_seek(con, -7L, 2L)
                else break
            }
            ## Read trailer info.
            read_next_non_whitespace_and_seek_back(con)
            new_trailer <- pdf_read_object(con)
            ## Merge with current trailer info.
            trailer[names(new_trailer)] <- new_trailer
            ## If the trailer info has a /Prev key, then redo the above
            ## with the corresponding value the new startxref.
            startxref <- new_trailer[["Prev"]]
            if(is.null(startxref)) break
        } else if(x %.IN.% pdf_bytes_digits) {
            ## PDF 1.5+ cross-reference stream, hopefully.
            .con_seek(con, -1L, 2L)
            pos <- .con_seek(con)
            hdr <- pdf_read_object_header(con)
            obj <- pdf_read_object(con)
            if(!("Type" %in% names(obj)) ||
               !(obj[["Type"]] == "XRef")) {
                ## Something's wrong.
                ## Try finding the xref table before pos.
                .con_seek(con, pos)
                startxref <- find_xref_start(con)
                next
            }
            size <- obj[["Size"]]
            index <- obj[["Index"]]
            index <- if(is.null(index)) {
                ## Use default [0 Size].
                cbind(0, size)
            } else {
                matrix(unlist(index), ncol = 2L, byrow = TRUE)
            }
            field_sizes <- unlist(obj[["W"]])
            stream <- rawConnection(PDF_Stream_get_data(obj))
            for(i in seq_len(nrow(index))) {
                num <- index[i, 1L]
                cnt <- 0L
                while(cnt < index[i, 2L]) {
                    bytes <- .con_read_bytes(stream, field_sizes[1L])
                    d1 <- strtoi(paste(bytes, collapse = ""), 16L)
                    bytes <- .con_read_bytes(stream, field_sizes[2L])
                    d2 <- strtoi(paste(bytes, collapse = ""), 16L)
                    bytes <- .con_read_bytes(stream, field_sizes[3L])
                    d3 <- strtoi(paste(bytes, collapse = ""), 16L)
                    ## Might actually need to overwrite entries.
                    ## Worry about that lateron ...
                    if(d1 == 1) {
                        xref_tabs <-
                            rbind(xref_tabs, c(num, d2, d3, TRUE))
                    } else if(d1 == 2) {
                        xref_objs <-
                            rbind(xref_objs, c(num, d2, d3))
                    }
                    cnt <- cnt + 1L
                    num <- num + 1L
                }
            }
            close(stream)
            keys <- c("Root", "Encrypt", "Info", "ID")
            pos <- match(keys, names(obj), nomatch = 0L)
            trailer[keys[pos > 0L]] <- obj[pos]
            startxref <- obj[["Prev"]]
            if(is.null(startxref)) break
        } else {
            .con_seek(con, -1L, 2L)
            startxref <- find_xref_start(con)
        }
    }

    ## Determine the "active" objects (all objects in cross-reference
    ## streams and objects in cross-reference tables marked in use and
    ## with a "real" position).
    ind <- (xref_tabs[, "pos"] > 0L) & (xref_tabs[, "use"] > 0L)
    names <-
        c(.ref_to_name(xref_tabs[ind, c("num", "gen"), drop = FALSE]),
          if(length(num <- xref_objs[, "num"]))
          .ref_to_name(cbind(num, 0)))
    ## Build an index of names as lists of object numbers with
    ## corresponding generation numbers in decreasing order.
    nums <- xref_objs[, "num"]
    gens <- rep.int(0L, length(nums))
    nums <- c(nums, xref_tabs[ind, "num"])
    gens <- c(gens, xref_tabs[ind, "gen"])
    gens_by_nums <-
        lapply(split(as.integer(gens), nums), sort, decreasing = TRUE)

    y <- new.env(parent = emptyenv())
    y$file <- file
    y$size <- nbytes
    y$header <- header
    y$xref_tabs <- xref_tabs
    y$xref_objs <- xref_objs
    y$trailer <- trailer
    y$cache <- cache
    y$con <- if(keep) con else NULL
    y$names <- names
    y$length <- length(names)
    y$gens_by_nums <- gens_by_nums
    y$objects <- list()
    class(y) <- "pdf_doc"
    y
}

print.pdf_doc <-
function(x, ...)
{
    writeLines(strwrap(sprintf("PDF document (file \"%s\", %d bytes, %d objects)",
                               x$file, x$size, x$length),
                       exdent = 4L))
    invisible(x)
}

length.pdf_doc <-
function(x)
    x$length

names.pdf_doc <-
function(x)
    x$names

`[.pdf_doc` <-
function(x, i)
{
    if(!inherits(x, "pdf_doc")) stop("wrong class")
    if(missing(i)) return(pdf_doc_get_objects(x))
    i <- as.character(i)                # For now ...
    out <- vector("list", length(i))
    pos <- .match_ids_to_pdf_doc_names(i, x)
    nms <- x$names[pos]
    names(out) <- nms
    ind <- !is.na(pos)
    out[ind] <- pdf_doc_get_objects(x, nms[ind])
    out
}

`[[.pdf_doc` <-
function(x, i)
{
    if(!inherits(x, "pdf_doc")) stop("wrong class")
    if(missing(i) || (!(len <- length(i <- as.character(i)))))
        stop("attempting to select less than one element")
    else if(len > 1L)
        stop("attempting to select more than one element")
    pos <- .match_ids_to_pdf_doc_names(i, x)
    if(is.na(pos)) return(NULL)
    pdf_doc_get_object(x, x$names[pos])
}

## * pdf_catalog

pdf_catalog <-
function(file)
{
    doc <- if(inherits(file, "pdf_doc")) file else pdf_doc(file)
    pdf_doc_get_object(doc, doc$trailer[["Root"]])
}

## * pdf_fonts

## <FIXME>
## Currently only extracts the fonts used in pages (but not, e.g.,
## forms).
## </FIXME>

pdf_fonts <-
function(file)
{
    doc <- if(inherits(file, "pdf_doc"))
        file
    else
        pdf_doc(file, cache = FALSE)

    con <- file(doc$file, "rb")
    on.exit(close(con))

    ## Get the page resources.
    resources <- pdf_doc_get_page_resources(doc, con)
    ## Get the font resources (actually, their references).
    frefs <- list()
    for(res in resources) {
        fonts <- pdf_dereference_maybe(res[["Font"]], doc, con)
        for(ref in fonts) {
            if(is.na(match(list(ref), frefs))) {
                frefs <- c(frefs, list(ref))
            }
        }
    }

    if(!length(frefs)) {
        tab <- data.frame(name = character(),
                          type = character(),
                          emb = logical(),
                          sub = logical(),
                          uni = logical(),
                          enc = logical(),
                          num = integer(),
                          gen = integer(),
                          stringsAsFactors = FALSE)
        tab$enc <- list()
        return(tab)
    }

    ## Now get the referenced font objects and extract some basic
    ## information in the style of pdffonts(1).
    ##   emb   "yes" if the font is embedded in the PDF file
    ##   sub   "yes" if the font is a subset
    ##   uni   "yes" if there is an explicit "ToUnicode" map in the PDF file
    ##         (the absence of a ToUnicode map doesn't necessarily mean that
    ##         the text can't be converted to Unicode)
    ## Re subset, see section 5.5.3 "Font Subsets" in the PDF ref:
    ##   For a font subset, the PostScript name of the font--the value
    ##   of the font's BaseFont entry and the font descriptor's FontName
    ##   entry--begins with a tag followed by a plus sign (+). The tag
    ##   consists of exactly six uppercase letters; the choice of
    ##   letters is arbitrary, but different subsets in the same PDF
    ##   file must have different tags.
    ## Also extract /Encoding information:
    ##   A specification of the font's character encoding if different
    ##   from its built-in encoding. The value of Encoding is either the
    ##   name of a predefined encoding (MacRomanEncoding,
    ##   MacExpertEncoding, or WinAnsiEncoding, as described in Appendix
    ##   D) or an encoding dictionary that specifies differences from
    ##   the font's built-in encoding or from a specified predefined
    ##   encoding (see Section 5.5.5, "Character Encoding").
    tab <- lapply(frefs,
                  function(ref) {
                      obj <- pdf_doc_get_object(doc, ref, con)
                      base <- obj[["BaseFont"]]
                      ## See PDF Reference version 1.7 section 5.5.4.
                      ## Type 3 font dictionaries have no BaseFont entry.
                      ## (Guess they are always embedded?)
                      if(is.null(base))
                          base <- "[none]"
                      else if(inherits(base,
                                       "PDF_Indirect_Reference")) {
                          base <- pdf_doc_get_object(doc, base, con)
                      }
                      list(base,
                           obj[["Subtype"]],
                           ((base == "[none]") ||
                            !is.null(obj[["FontDescriptor"]])),
                           grepl("^[[:upper:]]{6}\\+", base, perl = TRUE),
                           !is.null(obj[["ToUnicode"]]),
                           obj[["Encoding"]],
                           ref["num"],
                           ref["gen"])
                  })

    tab <- as.data.frame(do.call(rbind, tab))
    names(tab) <-
        c("name", "type", "emb", "sub", "uni", "enc", "num", "gen")
    ## <NOTE>
    ## This turns name and type from lists of PDF names to character.
    ## Maybe add methods for combining PDF_Name objects lateron ...
    ind <- names(tab) != "enc"
    tab[ind] <- lapply(tab[ind], unlist)
    ## </NOTE>
    ## <FIXME>
    ## Do something useful to the encoding information.
    ## For now, these are really NULL or indirect references ...
    ## </FIXME>

    class(tab) <- c("pdf_fonts", "data.frame")
    tab
}

format.pdf_fonts <-
function(x, ...)
{
    y <- format.data.frame(x, ...)
    ## For now, simply don't show the encoding information.
    ## Alternatively:
    ##   enc <- character(length(x$enc))
    ##   ind <- vapply(x$enc, is.null, FALSE)
    ##   enc[!ind] <- sapply(x$enc[!ind], format)
    ##   y$enc <- enc
    y$enc <- NULL
    y
}

print.pdf_fonts <-
function(x, ...)
{
    print.data.frame(format(x, ...))
    invisible(x)
}

## * pdf_info

pdf_info <-
function(file)
{
    doc <- if(inherits(file, "pdf_doc"))
        file
    else
        pdf_doc(file, cache = FALSE)

    if(is.null(con <- doc$con)) {
        con <- file(doc$file, "rb")
        on.exit(close(con))
    }

    ref <- doc$trailer[["Info"]]
    if(is.null(ref)) {
        info <- list()
    } else {
        info <- unclass(pdf_doc_get_object(doc, ref, con))
        ## Be nice (the PDF Reference does not explicitly say that
        ## values in the Document Information Dictionary may be indirect
        ## references):
        ind <- as.logical(sapply(info, inherits,
                                 "PDF_Indirect_Reference"))
        if(any(ind))
            info[ind] <-
                lapply(info[ind],
                       function(ref) pdf_doc_get_object(doc, ref, con))

        ## Transform text strings.
        ## See PDF Reference version 1.7 section 10.2.1:
        ##   The value associated with any key not specifically
        ##   mentioned in Table 10.2 must be a text string.
        ## If they are not PDF strings, drop them.
        keys <- c("CreationDate", "ModDate", "Trapped")
        pos <- which(is.na(match(names(info), keys)))
        ind <- as.logical(sapply(info[pos], inherits, "PDF_String"))
        info[pos[ind]] <-
            lapply(info[pos[ind]], PDF_Text_String_to_character)
        info[pos[!ind]] <- NULL

        ## Transform trapping information.
        ## Could provide default value "unknown".

        ## Transform dates to POSIXt if possible.
        if(!is.null(dt <- info[["CreationDate"]]))
            info[["CreationDate"]] <- PDF_Date_to_POSIXt(dt)
        if(!is.null(dt <- info[["ModDate"]]))
            info[["ModDate"]] <- PDF_Date_to_POSIXt(dt)
        ## Alternatively, use
        ##   keys <- c("CreationDate", "ModDate")
        ##   ind <- !is.na(match(names(info), keys))
        ##   info[ind] <- lapply(info[ind], PDF_Date_to_POSIXt)
    }

    pages <- pdf_doc_get_page_list(doc, con)
    info[["Pages"]] <- length(pages)

    rectangles <- lapply(pages, `[[`, "MediaBox")
    urx <- unlist(lapply(rectangles, `[[`, 3L))
    ury <- unlist(lapply(rectangles, `[[`, 4L))
    if((length(uurx <- unique(urx)) == 1L) &&
       (length(uury <- unique(ury)) == 1L)) {
        info["Page size"] <- sprintf("%s x %s pts", uurx, uury)
        pos <- which((abs(pdf_page_sizes[, 1L] - uurx) < 1) &
                     (abs(pdf_page_sizes[, 2L] - uury) < 1))
        if(!length(pos)) {
            pos <- which((abs(pdf_page_sizes[, 2L] - uurx) < 1) &
                         (abs(pdf_page_sizes[, 1L] - uury) < 1))
        }
        if(length(pos))
            info["Page size"] <-
                sprintf("%s [%s]",
                        info["Page size"],
                        rownames(pdf_page_sizes)[pos])
    }

    info[["File size"]] <- sprintf("%d bytes", doc$size)

    version <- substring(doc$header, 6L)
    catalog <- pdf_doc_get_object(doc, doc$trailer[["Root"]], con)
    version_in_catalog <- catalog[["Version"]]
    if(!is.null(version_in_catalog)) {
        ## Use version in catalog only if given (as a name) and later
        ## than the version specified in the header.
        if(as.numeric_version(version_in_catalog) > version)
            version <- version_in_catalog
    }
    info[["PDF version"]] <- version

    class(info) <- "pdf_info"
    info
}

format.pdf_info <-
function(x, ...)
{
    formatDL(sprintf("%s:", names(x)),
             sapply(x, format),
             ...)
}

## * Object readers

pdf_read_object <-
function(con, doc = NULL)
{
    if(pdftools_debug_level() > 0L) {
        bytes <- .con_read_bytes(con, 10L)
        message(sprintf("looking at %s", deparse(intToUtf8(bytes))))
        .con_seek(con, -length(bytes), 2L)
    }

    x <- read_next_non_whitespace(con)
    if(!length(x)) return(NA)
    .con_seek(con, -1L, 2L)
    if(x == 0x28)                       # charToRaw("(") => 28
        pdf_read_object_string_literal(con)
    else if(x == 0x2f)                  # charToRaw("/") => 2f
        pdf_read_object_name(con)
    else if(x == 0x5b)                  # charToRaw("[") => 5b
        pdf_read_object_array(con)
    ## <NOTE>
    ## Handled by pdf_read_object_keyword() now.
    ##   else if(x == "n")
    ##     pdf_read_object_null(con)
    ##   else if(x %in% c("t", "f"))
    ##     pdf_read_object_boolean(con)
    ## </NOTE>
    else if(x == 0x3c) {                # charToRaw("<") => 3c
        ## Hexadecimal string or dictionary
        bytes <- .con_read_bytes(con, 2L)
        .con_seek(con, -2L, 2L)
        if(all(bytes == c(0x3c, 0x3c)))
            pdf_read_object_dictionary_or_stream(con, doc)
        else
            pdf_read_object_string_hexadecimal(con)
    }
    else if(x == 0x25) {                # charToRaw("%") => 25
        ## Read until eol.
        repeat {
            x <- .con_read_bytes(con, 1L)
            if(x %.IN.% pdf_bytes_eols) break
        }
        read_next_non_whitespace_and_seek_back(con)
        pdf_read_object(con)
    }
    else if(x %.IN.% pdf_bytes_in_numerics_not_digits)
        pdf_read_object_numeric(con)
    else if(x %.IN.% pdf_bytes_digits) {
        ## Could be a number object or an indirect object reference.
        bytes <- .con_read_bytes(con, 20L)
        .con_seek(con, - length(bytes), 2L)
        ## Cannot simply call rawToChar(bytes) as we might have read nul
        ## bytes.
        if(length(pos <- which(bytes == 0))) {
            bytes <- bytes[seq_len(pos[1L] - 1L)]
        }
        if(grepl("^[[:digit:]]+\\s[[:digit:]]+\\sR[^[:alpha:]]",
                 rawToChar(bytes),
                 useBytes = TRUE))
            pdf_read_object_indirect_reference(con)
        else
            pdf_read_object_numeric(con)
    }
    else {
        ## A keyword, hopefully.
        pdf_read_object_keyword(con)
    }
}

## <NOTE>
## Handled by pdf_read_object_keyword() now.
##
## pdf_read_object_boolean <-
## function(con)
## {
##     x <- rawToChar(.con_read_bytes(con, 1L))
##     if(x == "t") {
##         bytes <- .con_read_bytes(con, 3L)
##         if(rawToChar(bytes) == "rue")
##             return(TRUE)
##     } else if(x == "f") {
##         bytes <- .con_read_bytes(con, 4L)
##         if(rawToChar(bytes) == "alse")
##             return(FALSE)
##     }
##     stop("cannot read boolean object")
## }
##
## </NOTE>

pdf_read_object_numeric <-
function(con)
{
    table <- pdf_bytes_in_numerics

    bytes <- raw()
    while((x <- .con_read_bytes(con, 1L)) %.IN.% table) {
        bytes <- c(bytes, x)
    }
    .con_seek(con, -1L, 2L)

    s <- rawToChar(bytes)
    if(grepl(".", s, fixed = TRUE))
        as.numeric(s)
    else
        as.integer(s)
}

## PDF string objects.

## See PDF Reference version 1.7 section 3.2.3:
## A PDF string simply is a sequence of bytes.
## As this may contain nuls, we cannot unconditionally represent these
## as R character strings (which must not have embedded nulls, even with
## a "bytes" encoding), and conditionalizing the representation seems
## rather awkward.
## Hence, we represent PDF strings as a byte (raw) vector of class
## "PDF_String".
## See PDF Reference version 1.7 section 3.8.1:
## PDF has the notion of a "text string" type
##   used for human-readable characters, such as text annotations,
##   bookmark names, article names, and document information.  These
##   strings are encoded using either PDFDocEncoding or UTF-16BE with a
##   leading byte-order marker.
## with note:
##   This is not a true data type, but a string type that represents
##   data encoded using specific conventions.
## As the context indicates when PDF strings are to be taken as PDF text
## strings (e.g. for the title or author specification in the Document
## Information Dictionary, see PDF Reference version 1.7 section 10.2.1),
## we do not use a subclass of "PDF_String" for text strings: instead,
## we use
##   PDF_Text_String_to_character()
## to convert the byte vector to an R character string encoded in
## UTF-8 when the text string context applies.
## (Maybe PDF_Text_String_to_UTF8() would be a better name?)

pdf_read_object_string_literal <-
function(con)
{
    x <- .con_read_bytes(con, 1L)
    lparen <- charToRaw("(")
    if(x != lparen)
        stop("cannot read literal string object")

    rparen <- charToRaw(")")
    escape <- charToRaw("\\")
    pdf_bytes_escape_tails <- charToRaw("nrtbf()\\")
    pdf_bytes_escape_bytes <- charToRaw("\n\r\t\b\f()\\")
    names(pdf_bytes_escape_bytes) <-
        as.character(pdf_bytes_escape_tails)

    bytes <- raw()
    parens <- 1L
    repeat {
        x <- .con_read_bytes(con, 1L)
        if(!length(x)) break
        if(x == lparen) {
            parens <- parens + 1L
        } else if(x == rparen) {
            parens <- parens - 1L
            if(!parens) break
        } else if(x == escape) {
            x <- .con_read_bytes(con, 1L)
            if(x %.IN.% pdf_bytes_digits) {
                i <- 0L
                while(i < 2L) {
                    y <- .con_read_bytes(con, 1L)
                    if(!(y %.IN.% pdf_bytes_digits)) {
                        .con_seek(con, -1L, 2L)
                        break
                    }
                    x <- c(x, y)
                    i <- i + 1L
                }
                x <- as.raw(strtoi(rawToChar(x), 8L))
            } else if(x %.IN.% pdf_bytes_escape_tails) {
                x <- pdf_bytes_escape_bytes[as.character(x)]
            } else if(x %.IN.% pdf_bytes_eols) {
                x <- .con_read_bytes(con, 1L)
                if(!(x %.IN.% pdf_bytes_eols))
                    .con_seek(con, -1L, 2L)
                x <- raw()
            }
            ## See PDF Reference version 1.7 section 3.2.3.
            ## If the character following the backslash is not not a
            ## special character for an escape sequence, the backslash
            ## is ignored.
        }
        bytes <- c(bytes, x)
    }
    class(bytes) <- "PDF_String"
    bytes
}

pdf_read_object_string_hexadecimal <-
function(con)
{
    x <- .con_read_bytes(con, 1L)
    if(x != 0x3c)                       # charToRaw("<") => 3c
        stop("cannot read hexadecimal string object")

    end <- charToRaw(">")

    ## See PDF Reference version 1.7 section 3.2.3:
    ## Each pair of hexadecimal digits defines one byte of the string.
    ## White-space characters are ignored.
    ## If the final digit of a hexadecimal string is missing (i.e., if
    ## there is an odd number of digits) it is assumed to be 0.
    bytes <- raw()
    repeat {
        x <- .con_read_bytes(con, 1L)
        if(x == end) break
        if(!(x %.IN.% pdf_bytes_whitespaces))
            bytes <- c(bytes, x)
    }

    if(length(bytes) %% 2)
        bytes <- c(bytes, charToRaw("0"))
    n <- length(bytes) %/% 2
    s <- substring(rawToChar(bytes),
                   seq(1L, by = 2L, length.out = n),
                   seq(2L, by = 2L, length.out = n))
    bytes <- as.raw(strtoi(s, 16L))
    class(bytes) <- "PDF_String"
    bytes
}

format.PDF_String <-
function(x, ...)
{
    sprintf("PDF_String(<%s>)", paste(as.character(x), collapse = ""))
}

## PDF name objects.

pdf_read_object_name <-
function(con)
{
    ## See PDF Reference version 1.7 section 3.2.4:
    ##   A slash character (/) introduces a name.  The slash is not part
    ##   of the name but is a prefix indicating that the following
    ##   sequence of characters constitutes a name.
    ##
    ##   The name may include any regular characters, but not delimiter
    ##   or white-space characters.
    ##
    ##   Beginning with PDF 1.2, any character except null (character
    ##   code 0) may be included in a name by writing its 2-digit
    ##   hexadecimal code, preceded by the number sign character (#).

    x <- .con_read_bytes(con, 1L)
    if(x != 0x2f)                       # charToRaw("/") => 2f
        stop("cannot read name object")

    bytes <- raw()
    repeat {
        x <- .con_read_bytes(con, 1L)
        if(!length(x) || (x %.IN.% pdf_bytes_non_regulars)) {
            .con_seek(con, -1L, 2L)
            break
        }
        bytes <- c(bytes, x)
    }

    ## Cf. also URLdecode().
    pos <- which(bytes == 0x23)         # charToRaw("#") => 23
    if(length(pos)) {
        hex <- sapply(pos,
                      function(p) rawToChar(bytes[p + (1L : 2L)]))
        bytes[pos] <- as.raw(strtoi(hex, 16L))
        bytes <- bytes[- c(pos + 1L, pos + 2L)]
    }
    ## Note that we currently leave the leading slash as part of the
    ## name.
    s <- rawToChar(bytes)
    class(s) <- "PDF_Name"
    s
}

print.PDF_Name <-
function(x, ...)
{
    print(noquote(unclass(x)), ...)
    invisible(x)
}

pdf_read_object_array <-
function(con)
{
    x <- .con_read_bytes(con, 1L)
    if(x != 0x5b)                       # charToRaw("[") => 5b
        stop("cannot read array object")

    end <- charToRaw("]")

    y <- list()
    repeat {
        x <- read_next_non_whitespace_and_seek_back(con)
        if(x == end) {
            .con_read_bytes(con, 1L)
            break
        }
        y <- c(y, list(pdf_read_object(con)))
    }
    class(y) <- "PDF_Array"
    y
}

format.PDF_Array <-
function(x, ...)
{
    sprintf("PDF_Array(%d)", length(x))
}

pdf_read_object_dictionary_or_stream <-
function(con, doc = NULL)
{
    bytes <- .con_read_bytes(con, 2L)
    if(!all(bytes == c(0x3c, 0x3c)))
        stop("cannot read dictionary object")

    end <- charToRaw(">")

    y <- list()
    repeat {
        x <- read_next_non_whitespace_and_seek_back(con)
        if(x == end) {
            .con_read_bytes(con, 2L)
            break
        }
        key <- pdf_read_object(con)
        read_next_non_whitespace_and_seek_back(con)
        val <- pdf_read_object(con)
        y[key] <- list(val)
    }
    pos <- .con_seek(con)
    ## Check whether this is in fact a stream object.
    ## Read ahead.
    read_next_non_whitespace_and_seek_back(con)
    if(rawToChar(.con_read_bytes(con, 6L)) == "stream") {
        ## Argh.  Handle the EOL marker assuming compliance: should
        ## check for this.
        eol <- .con_read_bytes(con, 1L)
        if(!(eol %.IN.% pdf_bytes_eols))
            stop("cannot read stream object")
        if(eol == charToRaw("\r"))
            .con_read_bytes(con, 1L)
        ## Need length information in dictionary.
        len <- y[["Length"]]
        if(is.null(len))
            stop("cannot read stream object")
        ## However, the length could be an indirect object reference.
        ## In this case we can only resolve the length for a non-NULL
        ## doc with the cross-reference needed.  Otherwise, we record
        ## the stream data start, and defer reading the bytes.
        if((ref <- inherits(len, "PDF_Indirect_Reference")) &&
           is.null(doc)) {
            y[["__stream_start__"]] <- .con_seek(con)
            y[["__stream_bytes__"]] <- NULL
        } else {
            if(ref) {
                tell <- .con_seek(con)
                len <- pdf_doc_get_object(doc, len, con)
                .con_seek(con, tell)
            }
            y[["__stream_bytes__"]] <- .con_read_bytes(con, len)
            ## Now check if we really hit the end of the stream.
            read_next_non_whitespace_and_seek_back(con)
            bytes <- .con_read_bytes(con, 9L)
            if(rawToChar(bytes) != "endstream")
                stop("cannot read stream object")
        }
        class(y) <- "PDF_Stream"
    } else {
        .con_seek(con, pos)
        class(y) <- "PDF_Dictionary"
    }
    y
}

format.PDF_Dictionary <-
function(x, ...)
{
    sprintf("PDF_Dictionary(<<%s>>)",
            paste(names(x), collapse = ","))
}

format.PDF_Stream <-
function(x, ...)
{
    sprintf("PDF_Stream(<<%s>>)",
            paste(names(x), collapse = ","))
}

## Experimental summary methods.
## Cannot easily make this the print method, because PDF dictionary
## and stream objects can be recursive ...

summary.PDF_Dictionary <-
function(object, ...)
    writeLines(sprintf("%s: %s", names(object), sapply(object, format)))

summary.PDF_Stream <-
function(object, ...)
{
    if(!is.null(bytes <- object[["__stream_bytes__"]]))
        object[["__stream_bytes__"]] <-
            sprintf("%d bytes", length(bytes))
    writeLines(sprintf("%s: %s", names(object), sapply(object, format)))
}

## <NOTE>
## Handled by pdf_read_object_keyword() now.
##
## pdf_read_object_null <-
## function(con)
## {
##     bytes <- .con_read_bytes(con, 4L)
##     if(rawToChar(bytes) != "null")
##         stop("cannot read null object")
##     NULL
## }
##
## </NOTE>

pdf_read_object_indirect_reference <-
function(con)
{
    num <- read_next_bytes_until_whitespace(con)
    read_next_non_whitespace_and_seek_back(con)
    gen <- read_next_bytes_until_whitespace(con)
    read_next_non_whitespace_and_seek_back(con)
    x <- .con_read_bytes(con, 1L)
    if(x != 0x52)                       # charToRaw("R") => 52
        stop("cannot read indirect reference object")
    y <- c(num = as.integer(rawToChar(num)),
           gen = as.integer(rawToChar(gen)))
    class(y) <- "PDF_Indirect_Reference"
    y
}

format.PDF_Indirect_Reference <-
function(x, ...)
{
    sprintf("PDF_Indirect_Reference(%d,%d)", x["num"], x["gen"])
}

pdf_dereference_maybe <-
function(obj, doc, con = NULL)
{
    if(inherits(obj, "PDF_Indirect_Reference"))
        obj <- pdf_doc_get_object(doc, obj, con)
    obj
}

pdf_read_object_keyword <-
function(con)
{
    bytes <- raw()
    repeat {
        x <- .con_read_bytes(con, 1L)
        if(!length(x) || !(x %.IN.% pdf_bytes_in_keywords)) {
            .con_seek(con, -1L, 2L)
            break
        }
        bytes <- c(bytes, x)
    }

    s <- rawToChar(bytes)
    if(s == "null")
        NULL
    else if(s == "true")
        TRUE
    else if(s == "false")
        FALSE
    else {
        class(s) <- "PDF_Keyword"
        s
    }
}

print.PDF_Keyword <-
function(x, ...)
{
    print(noquote(unclass(x)), ...)
    invisible(x)
}

pdf_read_object_header <-
function(con)
{
    ## Read num and gen.
    read_next_non_whitespace_and_seek_back(con)
    num <- read_next_bytes_until_whitespace(con)
    read_next_non_whitespace_and_seek_back(con)
    gen <- read_next_bytes_until_whitespace(con)
    ## Now skip the "obj".
    .con_read_bytes(con, 3L)
    read_next_non_whitespace_and_seek_back(con)
    c(num = suppressWarnings(as.integer(rawToChar(num))),
      gen = suppressWarnings(as.integer(rawToChar(gen))))
}

pdf_read_indirect_object_at_pos <-
function(con, pos, num = NA_integer_, gen = NA_integer_, doc = NULL)
{
    ## Move to pos.
    .con_seek(con, pos)
    ## Read header first.
    hdr <- pdf_read_object_header(con)
    ## Be paranoid.
    if(anyNA(hdr))
        stop(gettextf("cannot find object header at xrefed position %d",
                      pos),
             domain = NA)
    ## Apparently it is feasible to have cross-references to indirect
    ## objects with actually different object and/or generation numbers:
    ## as of 2011-09-27, grImport/inst/doc/Rnewspage27.pdf had both
    ## objects 69 and 70 point to the same offset [providing object 70].
    ## For now, give a message and proceed.
    if(!is.na(num) && (num != hdr["num"]))
        message(gettextf("mismatch in object numbers (given: %d, found: %d)",
                         num, hdr["num"]),
                domain = NA)
    if(!is.na(gen) && (gen != hdr["gen"]))
        message(gettextf("mismatch in generation numbers (given: %d, found: %d)",
                         gen, hdr["gen"]),
                domain = NA)
    ## Read object.
    pdf_read_object(con, doc)
}

pdf_read_stream_bytes <-
function(con, obj, doc = NULL)
{
    len <- obj[["Length"]]
    if(inherits(len, "PDF_Indirect_Reference")) {
        len <- pdf_doc_get_object(doc, len, con)
    }
    pos <- obj[["__stream_start__"]]
    .con_seek(con, pos)
    bytes <- .con_read_bytes(con, len)
    ## Check if we really hit the end of the stream.
    read_next_non_whitespace_and_seek_back(con)
    if(rawToChar(.con_read_bytes(con, 9L)) != "endstream")
        stop("cannot read stream data")
    bytes
}

pdf_doc_get_object <-
function(doc, ref, con = NULL)
{
    if(!inherits(doc, "pdf_doc")) stop("wrong class")

    if(is.character(ref)) {
        ref <- as.integer(unlist(strsplit(ref, ".", fixed = TRUE)))
    }

    if(length(ref) == 1L) {
        names(ref) <- "num"
    } else if(length(ref) == 2L) {
        names(ref) <- c("num", "gen")
    }
    num <- ref["num"]
    gen <- ref["gen"]

    ## First look in the object cache.
    if(doc$cache) {
        pos <- match(.ref_to_name(ref), names(doc$objects))
        if(!is.na(pos)) return(doc$objects[[pos]])
    }

    if(is.null(con) && is.null(con <- doc$con)) {
        con <- file(doc$file, "rb")
        on.exit(close(con))
    }

    ## Next look in the xrefs for object streams.
    if((is.na(gen) || (gen == 0L)) &&
       (length(pos <- which(doc$xref_objs[, "num"] == num)))) {
        if(length(pos) > 1L) {
            ## Can this really happen?
            pos <- pos[1L]
        }
        ptr <- doc$xref_objs[pos, ]
        idx <- ptr["idx"]
        obj <- pdf_doc_get_object(doc, ptr["str"], con)
        ## Could check whether
        ##   obj[["Type"]] == "ObjStm"
        n <- obj[["N"]]
        if(idx >= n)
            stop("invalid index in object stream lookup")
        first <- obj[["First"]]
        stream <- rawConnection(PDF_Stream_get_data(obj, doc))
        on.exit(close(stream), add = TRUE)
        i <- 0L
        if(doc$cache) {
            while(i < n) {
                cnum <- pdf_read_object(stream)
                read_next_non_whitespace_and_seek_back(stream)
                cpos <- pdf_read_object(stream)
                read_next_non_whitespace_and_seek_back(stream)
                tell <- .con_seek(stream, first + cpos)
                obj <- pdf_read_object(stream, doc)
                key <- .ref_to_name(cnum)
                doc$objects[key] <- list(obj)
                .con_seek(stream, tell)
                i <- i + 1L
            }
            return(doc$objects[[.ref_to_name(num)]])
        } else {
            while(i <= idx) {
                cnum <- pdf_read_object(stream)
                read_next_non_whitespace_and_seek_back(stream)
                cpos <- pdf_read_object(stream)
                read_next_non_whitespace_and_seek_back(stream)
                i <- i + 1L
            }
            .con_seek(stream, obj[["First"]] + cpos)
            return(pdf_read_object(stream, doc))
        }
    }

    ## Figure out the position to start from.
    if(length(ref) == 1L) {
	pos <- which.max(doc$xref_tabs[, "num"] == ref)
        gen <- doc$xref_tabs[pos, "gen"]
        pos <- doc$xref_tabs[pos, "pos"]
    }
    else {
        ind <- ((doc$xref_tabs[, "num"] == num) &
                (doc$xref_tabs[, "gen"] == gen))
        pos <- doc$xref_tabs[ind, "pos"]
    }

    obj <- pdf_read_indirect_object_at_pos(con, pos, num, gen, doc)
    if(doc$cache)
        doc$objects[.ref_to_name(c(num, gen))] <- list(obj)
    obj
}

pdf_doc_get_objects <-
function(doc, ids = NULL, con = NULL)
{
    if(!inherits(doc, "pdf_doc")) stop("wrong class")

    ## Start with the object cache.
    objects <- doc$objects

    ## If this contains as many objects as there are names, all objects
    ## have already been cached.
    if(length(objects) == doc$length) {
        if(!length(ids))
            return(objects)
        else
            return(objects[ids])
    }

    ## Otherwise, we need to get the objects not yet in the cache (which
    ## could be all objects if caching is off, of course).

    if(is.null(con) && is.null(con <- doc$con)) {
        con <- file(doc$file, "rb")
        on.exit(close(con))
    }

    debug <- (pdftools_debug_level() > 0L)

    ## First get the objects from the old-style xref tables.
    tab <- doc$xref_tabs
    str <- .ref_to_name(doc$xref_objs[, "str"], "0")
    ## Determine the active objects needed.
    tab <- tab[((tab[, "pos"] > 0L) & (tab[, "use"] > 0L)), ,
               drop = FALSE]
    ## If ids is NULL (so that we are getting all active objects), we
    ## need those active objects not yet in the cache.
    ind <- is.na(match(.ref_to_name(tab[, c("num", "gen"),
                                        drop = FALSE]),
                       names(objects)))
    ## Otherwise, we only need those active objects not yet in the cache
    ## which are directly matched by ids, or which contain streams with
    ## objects matched by ids.
    if(length(ids)) {
        nms <- .ref_to_name(tab[ind, c("num", "gen"), drop = FALSE])
        wanted_by_direct_match <- !is.na(match(nms, ids))
        if(!length(str)) {
            ind <- ind & wanted_by_direct_match
        } else {
            pos <- match(ids,
                         .ref_to_name(doc$xref_objs[, "num"], "0"),
                         nomatch = 0L)
            str <- str[pos]
            wanted_by_stream_match <- !is.na(match(nms, unique(str)))
            ind <- ind & (wanted_by_direct_match | wanted_by_stream_match)
        }
    }

    for(i in which(ind)) {
        entry <- tab[i, ]
        if(debug)
            message(sprintf("processing %s",
                            paste(names(entry), entry, collapse = " ")))
        pos <- entry["pos"]
        num <- entry["num"]
        gen <- entry["gen"]
        obj <- pdf_read_indirect_object_at_pos(con, pos, num, gen, doc)
        key <- .ref_to_name(c(num, gen))
        if(doc$cache)
            doc$objects[key] <- list(obj)
        objects[key] <- list(obj)
    }
    ## Now for the new-style xref streams objects.
    for(s in unique(str)) {
        obj <- objects[[s]]
        n <- obj[["N"]]
        first <- obj[["First"]]
        stream <- rawConnection(PDF_Stream_get_data(obj, doc))
        tab <- matrix(0, n, 2L)
        ## First read the object numbers and byte offsets.
        i <- 1L
        while(i <= n) {
            tab[i, 1L] <- pdf_read_object(stream)
            read_next_non_whitespace_and_seek_back(stream)
            tab[i, 2L] <- pdf_read_object(stream)
            read_next_non_whitespace_and_seek_back(stream)
            i <- i + 1L
        }
        ## Determine the objects still needed.
        pos <- which(is.na(match(.ref_to_name(tab[, 1L], 0),
                                 names(objects))))
        if(length(ids)) {
            pos <- pos[!is.na(match(.ref_to_name(tab[pos, 1L], 0), ids))]
        }
        ## Then read the objects from the stream.
        for(i in pos) {
            .con_seek(stream, first + tab[i, 2L])
            obj <- pdf_read_object(stream, doc)
            key <- .ref_to_name(tab[i, 1L])
            if(doc$cache)
                doc$objects[key] <- list(obj)
            objects[key] <- list(obj)
        }
        close(stream)
    }

    if(length(ids))
        objects <- objects[ids]

    objects
}

## * pdf_doc_get_page_tree

pdf_doc_get_page_tree <-
function(doc, con = NULL)
{
    if(!inherits(doc, "pdf_doc")) stop("wrong class")

    if(is.null(con) && is.null(con <- doc$con)) {
        con <- file(doc$file, "rb")
        on.exit(close(con))
    }

    debug <- (pdftools_debug_level() > 0L)

    catalog <- pdf_doc_get_object(doc, doc$trailer[["Root"]], con)
    ## Pages entry in the catalog dictionary is required and must be an
    ## indirect reference.
    pages <- pdf_doc_get_object(doc, catalog[["Pages"]], con)
    recurse <- function(x) {
        if(!is.null(kids <- x[["Kids"]])) {
            x[["Kids"]] <-
                lapply(kids,
                       function(kid)
                       if(inherits(kid, "PDF_Indirect_Reference")) {
                           if(debug) {
                               message(sprintf("expanding %s",
                                               format(kid)))
                           }
                           recurse(pdf_doc_get_object(doc, kid, con))
                       } else {
                           kid
                       })
            class(x) <- "PDF_Page_Tree"
        } else {
            ## No more kids, should be a leaf node.
            ## Could check on Type being Page.
            class(x) <- "PDF_Page"
        }
        x
    }
    recurse(pages)
}

pdf_doc_get_page_list <-
function(doc, con = NULL)
{
    if(!inherits(doc, "pdf_doc")) stop("wrong class")

    if(is.null(con) && is.null(con <- doc$con)) {
        con <- file(doc$file, "rb")
        on.exit(close(con))
    }

    ## See PDF Reference version 1.7 section 3.6.2.
    ## Page objects can inherit
    ##   Resources MediaBox CropBox Rotate
    ## from its ancestors.
    ## Hence, we flattening out the tree to the list of pages (leaf
    ## nodes of the page tree), propagate these entries.
    inherited_entry_names <-
        c("Resources", "MediaBox", "CropBox", "Rotate")

    pages <- list()
    ## Cannot use rapply() because this only deals with nodes which are
    ## not lists.
    recurse <- function(x) {
        if(!is.null(kids <- x[["Kids"]])) {
            entries <- x[inherited_entry_names]
            for(kid in kids) {
                cls <- class(kid)
                kid <- c(kid, entries[is.na(match(names(entries),
                                                  names(kids)))])
                class(kid) <- cls
                if(inherits(kid, "PDF_Page")) {
                    pages <<- c(pages, list(kid))
                }
                recurse(kid)
            }
        }
    }
    recurse(pdf_doc_get_page_tree(doc, con))
    pages
}

## * pdf_doc_get_content_streams

## <FIXME>
## Most likely this should only extract the Contents entries and let the
## "consumers" do the expansions of indirect object references as needed.
## </FIXME>

pdf_doc_get_page_content_streams <-
function(doc, con = NULL)
{
    if(!inherits(doc, "pdf_doc")) stop("wrong class")

    if(is.null(con) && is.null(con <- doc$con)) {
        con <- file(doc$file, "rb")
        on.exit(close(con))
    }

    pages <- pdf_doc_get_page_list(doc, con)
    ## See PDF Reference version 1.7 section 3.6.2.
    ## A page object may have a Contents entry with value a single
    ## content stream or an array of such streams.
    ## A missing Contents entry means that the page is empty.
    lapply(pages,
           function(p) {
               obj <- p[["Contents"]]
               if(inherits(obj, "PDF_Array"))
                   lapply(obj, pdf_dereference_maybe, doc, con)
               else
                   pdf_dereference_maybe(obj, doc, con)
           })
}

## <FIXME>
## Most likely this should only extract the Resources entries and let the
## "consumers" do the expansions of indirect object references as needed
## (as well as handle inheritance from ancestors).
## </FIXME>

pdf_doc_get_page_resources <-
function(doc, con = NULL)
{
    if(!inherits(doc, "pdf_doc")) stop("wrong class")

    if(is.null(con) && is.null(con <- doc$con)) {
        con <- file(doc$file, "rb")
        on.exit(close(con))
    }

    pages <- pdf_doc_get_page_list(doc, con)

    ## See PDF Reference version 1.7 section 3.6.2.
    ## A page object may have a Resources entry giving a dictionary
    ## (which apparently could be an indirect object reference).
    ## An empty dictionary means no resources.
    ## A missing Resources entry means that resources are inherited from
    ## an ancestor node in the page tree.
    lapply(pages,
           function(p) {
               pdf_dereference_maybe(p[["Resources"]], doc, con)
           })
}

## * Streams

PDF_Stream_get_data <-
function(obj, doc = NULL)
{
    bytes <- obj[["__stream_bytes__"]]

    if(is.null(bytes)) {
        if(is.null(doc))
            stop("cannot read stream data")
        con <- doc$con
        if(is.null(con)) {
            con <- file(doc$file, "rb")
            on.exit(close(con))
        }
        bytes <- pdf_read_stream_bytes(con, obj, doc)
    }

    filters <- as.list(obj[["Filter"]])
    ## Handle DecodeParms.
    ## The PDF specs say that if there is a single filter, DecodeParms
    ## can be a dictionary object with the parameters, but need not be
    ## given if the defaults are to be used.  If there are multiple
    ## filters and any filter has non-default parameters, DecodeParms
    ## must be an array with one entry for each filter: either a
    ## dictionary with the parameters or the null object.
    parameters <- obj[["DecodeParms"]]
    if(is.null(parameters))
        parameters <- rep.int(list(NULL), length(filters))
    else if(inherits(parameters, "PDF_Dictionary"))
        parameters <- list(parameters)
    for(i in seq_along(filters)) {
        filter <- filters[[i]]
        if(filter == "FlateDecode")
            bytes <- pdf_filter_flate_decode(bytes, parameters[[i]])
        else
            stop(gettextf("unsupported filter %s",
                          sQuote(filter)),
                 domain = NA)
    }
    bytes
}

## * Filters

pdf_filter_flate_decode <-
function(x, params)
{
    ## Need to decompress first
    m <- memDecompress(x, "gzip")
    predictor <- params[["Predictor"]]
    if(is.null(predictor) || (predictor == 1L))
        return(m)
    if((predictor < 10L) && (predictor > 15L)) {
        stop(gettextf("unsupported %s predictor %d",
                      "flatedecode",
                      predictor),
             domain = NA)
    }
    columns <- params[["Columns"]]
    bytes <- raw()
    rowlength <- columns + 1L
    prev_rowdata <- integer(rowlength)
    for(row in seq(0L, length.out = length(m) / rowlength)) {
        ## <FIXME>
        ## Use a rawConnection() instead.
        rowdata <- as.integer(m[seq(row * rowlength + 1L,
                                    (row + 1L) * rowlength)])
        ## </FIXME>
        fb <- rowdata[1L]
        if(fb == 1L) {
            for(i in seq(3L, rowlength))
                rowdata[i] <- (rowdata[i] + rowdata[i - 1L]) %% 256
        } else if(fb == 2L) {
            for(i in seq(2L, rowlength))
                rowdata[i] <- (rowdata[i] + prev_rowdata[i]) %% 256
        } else if(fb != 0L) {
            stop(gettextf("unsupported PNG filter %d", fb),
                 domain = NA)
        }
        prev_rowdata <- rowdata
        bytes <- c(bytes, as.raw(rowdata[-1L]))
    }
    bytes
}

## * Content streams

pdf_content_stream_read_objects <-
function(con, doc = NULL)
{
    objects <- list()
    while(!identical(obj <- pdf_read_object(con, doc), NA))
        objects <- c(objects, list(obj))
    objects
}

## * Common data structures

## ** PDF text strings

PDF_Text_String_to_character <-
function(bytes)
{
    ## PDF text strings can be encoded in PDFDocEncoding ot UTF-16BE.
    if(identical(bytes[c(1L, 2L)], as.raw(c(0xfe, 0xff)))) {
        ## If the first two bytes represent the Unicode byte-order marker
        ## U+FEFF, this is a text string encoded in UTF-16BE.
        bytes <- bytes[-c(1L, 2L)]
        ## <NOTE>
        ##   This can contain the language encoding as
        ##     U+001B (i.e., as.raw(c(0x00, 0x1b)))
        ##     2-byte ISO-639 language code
        ##     2-byte ISO-639 language code [optional]
        ##     U+001B
        ## </NOTE>
        language <- NULL
        pos <- which(bytes == 0x00)
        if(length(pos)) {
            pos <- pos[bytes[pos + 1L] == 0x1b]
            if(length(pos) == 2L) {
                ini <- pos[1L]
                len <- pos[2L] - ini
                if(len == 4L) {
                    language <- rawToChar(bytes[c(ini + 2L, ini + 3L)])
                    bytes <- bytes[- (ini + (0L : 5L))]
                } else if(len == 6L) {
                    ## Use IETF language tag format.
                    language <-
                        paste(rawToChar(bytes[c(ini + 2L, ini + 3L)]),
                              rawToChar(bytes[c(ini + 4L, ini + 5L)]),
                              sep = "-")
                    bytes <- bytes[- (ini + (0L : 7L))]
                }
            }
        }
        s <- intToUtf8(bytes)
        if(!is.null(language))
            attr(s, "Language") <- language
        s
    } else {
        intToUtf8(PDFDocEncoding[as.character(bytes)])
    }
}

## <FIXME>
## Integrate into tools::charset_to_Unicode eventually.
PDFDocEncoding <-
    c(0x0000, 0xfffd, 0xfffd, 0xfffd, 0xfffd, 0xfffd, 0xfffd, 0xfffd,
      0xfffd, 0x0009, 0x000a, 0xfffd, 0x000c, 0x000d, 0xfffd, 0xfffd,
      0xfffd, 0xfffd, 0xfffd, 0xfffd, 0xfffd, 0xfffd, 0xfffd, 0xfffd,
      0x02d8, 0x02c7, 0x02c6, 0x02d9, 0x02dd, 0x02db, 0x02da, 0x02dc,
      0x0020, 0x0021, 0x0022, 0x0023, 0x0024, 0x0025, 0x0026, 0x0027,
      0x0028, 0x0029, 0x002a, 0x002b, 0x002c, 0x002d, 0x002e, 0x002f,
      0x0030, 0x0031, 0x0032, 0x0033, 0x0034, 0x0035, 0x0036, 0x0037,
      0x0038, 0x0039, 0x003a, 0x003b, 0x003c, 0x003d, 0x003e, 0x003f,
      0x0040, 0x0041, 0x0042, 0x0043, 0x0044, 0x0045, 0x0046, 0x0047,
      0x0048, 0x0049, 0x004a, 0x004b, 0x004c, 0x004d, 0x004e, 0x004f,
      0x0050, 0x0051, 0x0052, 0x0053, 0x0054, 0x0055, 0x0056, 0x0057,
      0x0058, 0x0059, 0x005a, 0x005b, 0x005c, 0x005d, 0x005e, 0x005f,
      0x0060, 0x0061, 0x0062, 0x0063, 0x0064, 0x0065, 0x0066, 0x0067,
      0x0068, 0x0069, 0x006a, 0x006b, 0x006c, 0x006d, 0x006e, 0x006f,
      0x0070, 0x0071, 0x0072, 0x0073, 0x0074, 0x0075, 0x0076, 0x0077,
      0x0078, 0x0079, 0x007a, 0x007b, 0x007c, 0x007d, 0x007e, 0xfffd,
      0x2022, 0x2020, 0x2021, 0x2026, 0x2014, 0x2013, 0x0192, 0x2044,
      0x2039, 0x203a, 0x2212, 0x2030, 0x201e, 0x201c, 0x201d, 0x2018,
      0x2019, 0x201a, 0x2122, 0xfb01, 0xfb02, 0x0141, 0x0152, 0x0160,
      0x0178, 0x017d, 0x0131, 0x0142, 0x0153, 0x0161, 0x017e, 0xfffd,
      0x20ac, 0x00a1, 0x00a2, 0x00a3, 0x00a4, 0x00a5, 0x00a6, 0x00a7,
      0x00a8, 0x00a9, 0x00aa, 0x00ab, 0x00ac, 0xfffd, 0x00ae, 0x00af,
      0x00b0, 0x00b1, 0x00b2, 0x00b3, 0x00b4, 0x00b5, 0x00b6, 0x00b7,
      0x00b8, 0x00b9, 0x00ba, 0x00bb, 0x00bc, 0x00bd, 0x00be, 0x00bf,
      0x00c0, 0x00c1, 0x00c2, 0x00c3, 0x00c4, 0x00c5, 0x00c6, 0x00c7,
      0x00c8, 0x00c9, 0x00ca, 0x00cb, 0x00cc, 0x00cd, 0x00ce, 0x00cf,
      0x00d0, 0x00d1, 0x00d2, 0x00d3, 0x00d4, 0x00d5, 0x00d6, 0x00d7,
      0x00d8, 0x00d9, 0x00da, 0x00db, 0x00dc, 0x00dd, 0x00de, 0x00df,
      0x00e0, 0x00e1, 0x00e2, 0x00e3, 0x00e4, 0x00e5, 0x00e6, 0x00e7,
      0x00e8, 0x00e9, 0x00ea, 0x00eb, 0x00ec, 0x00ed, 0x00ee, 0x00ef,
      0x00f0, 0x00f1, 0x00f2, 0x00f3, 0x00f4, 0x00f5, 0x00f6, 0x00f7,
      0x00f8, 0x00f9, 0x00fa, 0x00fb, 0x00fc, 0x00fd, 0x00fe, 0x00ff)
names(PDFDocEncoding) <- format.hexmode(0 : 255)
## </FIXME>

## ** PDF dates

## See PDF Reference version 1.7 section 3.8.3.
## Dates are of the form
##   (D:YYYYMMDDHHmmSSOHH'mm')
## where
## * YYYY MM DD HH mm SS have the usual meanings
## * O is the relationship of local time to Universal Time (UT),
##   denoted by one of the characters +, -, or Z: a plus sign (+) as
##   the value of the O field signifies that local time is later
##   than UT, a minus sign (-) signifies that local time is earlier
##   than UT, and the letter Z signifies that local time is UT.
## * the apostrophe character after HH and mm is part of the syntax
## * all fields after the year are optional
## * the prefix 'D:', although also optional, is strongly recommended
## * the default values for MM and DD are both 01
## * all other numerical fields default to zero values.
PDF_Date_to_POSIXt <-
function(bytes)
{
    ## Strip optional 'D:' prefix.
    s <- sub("^D:", "", rawToChar(bytes))
    ## Strip apostrophes in offset spec.
    s <- gsub("'", "", s)
    if(nchar(s) <= 14L) {
        s <- sprintf("%s%s", s,
                     substring("    0101000000", nchar(s) + 1L, 14L))
        strptime(s, "%Y%m%d%H%M%S")
    } else if(substring(s, 15L, 15L) == "Z") {
        strptime(substring(s, 1L, 14L), "%Y%m%d%H%M%S")
    } else {
        strptime(s, "%Y%m%d%H%M%S%z")
    }
}

## * Utilities

.match_ids_to_pdf_doc_names <-
function(ids, doc)
{
    ids <- as.character(ids)
    ## Exact matches first.
    pos <- match(ids, doc$names)
    if(any(ind <- is.na(pos))) {
        ## Try expanding a num-only id to the one with highest gen.
        num <- ids[ind]
        yep <- match(num, names(doc$gens_by_nums), nomatch = 0L)
        gen <- vapply(doc$gens_by_nums[yep], `[[`, 0L, 1L)
        yep <- (yep > 0L)
        pos[ind][yep] <-
            match(.ref_to_name(num[yep], gen), doc$names)
    }
    pos
}

.ref_to_name <-
function(x, y = NULL)
{
    sep <- "."
    if(!length(x))
        character()
    else if(!is.null(y)) {
        y <- rep(y, length.out = length(x))
        paste(x, y, sep = sep)
    }
    else if(is.matrix(x))
        paste(x[, 1L], x[, 2L], sep = sep)
    else if(length(x) > 1L)
        paste(x[1L], x[2L], sep = sep)
    else
        paste(x, "0", sep = sep)
}

read_next_bytes_until_whitespace <-
function(con)
{
    bytes <- raw()
    repeat {
        x <- .con_read_bytes(con, 1L)
        if(!length(x) || (x %.IN.% pdf_bytes_whitespaces)) break
        bytes <- c(bytes, x)
    }
    bytes
}

read_next_non_whitespace <-
function(con)
{
    repeat {
        x <- .con_read_bytes(con, 1L)
        if(!length(x) || !(x %.IN.% pdf_bytes_whitespaces)) break
    }
    x
}

read_next_non_whitespace_and_seek_back <-
function(con)
{
    x <- read_next_non_whitespace(con)
    .con_seek(con, -1L, 2L)
    x
}

read_prev_bytes_after_bytes <-
function(con, set)
{
    ## Read the previous bytes from con until the first byte in set, and
    ## move point to the first preceding byte not in set.
    bytes <- raw()
    repeat {
        x <- .con_read_bytes(con, 1L)
        .con_seek(con, -2L, 2L)
        if(x %.IN.% set) {
            while(x %.IN.% set) {
                x <- .con_read_bytes(con, 1L)
                .con_seek(con, -2L, 2L)
            }
            .con_seek(con, 1, 2L)
            break
        } else {
            bytes <- c(x, bytes)
        }
    }
    bytes
}

read_prev_bytes_after_eols <-
function(con)
    read_prev_bytes_after_bytes(con, pdf_bytes_eols)

raw_connection_to_bytes_in_file <-
function(file)
{
    bytes <- readBin(file, "raw", file.info(file)$size)
    rawConnection(bytes)
}

## * Utilities to enhance performance

## Test whether a single byte is contained in a sequence of bytes.
`%.IN.%` <-
function(x, bytes)
    any(x == bytes)
## Seems that this is faster than using grepRaw(fixed = TRUE) or
## match().

## Calling seek() is inefficient.
## * 1st, it dispatched to seek.connection().
## * 2nd, this pmatches two of its arguments before calling a .Internal.
## Hence, use the following, where values 1L, 2L, 3L for the origin
## correspond to "start", "current" and "end".

.con_seek <-
function(con, where = NA, origin = 1L)
{
    .Internal(seek(con, as.double(where), as.integer(origin), 0L))
}

## Calling readBin() to read bytes is somewhat inefficient.
## Hence, use the following.

.con_read_bytes <-
function(con, n = 1L)
{
    .Internal(readBin(con, "raw", n, NA_integer_, FALSE, FALSE))
}

## * Utilities for debugging

pdftools_debug_level <-
local({
    level <- 0L
    function(new) {
        if(!missing(new))
            level <<- new
        else
            level
    }
})
#  File src/library/tools/R/pkgDepends.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2012 The R 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 of the License, 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/

pkgDepends <- function(pkg, recursive=TRUE, local=TRUE,
                       reduce=TRUE, lib.loc=NULL) {
    if (length(pkg) != 1L)
        stop("argument 'pkg' must be of length 1")

    instPkgs <- utils::installed.packages(lib.loc=lib.loc)

    depMtrx <- getDepMtrx(pkg, instPkgs, local)
    if (is.null(depMtrx))               # Package was not found
        stop(gettextf("package '%s' was not found", pkg),
             domain = NA)

    getDepList(depMtrx, instPkgs, recursive, local, reduce, lib.loc)
}

getDepList <- function(depMtrx, instPkgs, recursive=TRUE,
                       local=TRUE, reduce=TRUE, lib.loc=NULL) {
    out <- list(Depends=character(), Installed=character(),
                Found=list(), NotFound=character(),
                R=character())
    class(out) <- c("DependsList", class(out))

    if ((!is.matrix(depMtrx))&&(is.na(depMtrx))) # no dependencies
        return(out)

    mtrxList <- buildDepList(depMtrx, instPkgs, recursive, lib.loc)

    if (local == FALSE) {
        toFind <- mtrxList$Depends[!apply(mtrxList$Depends, 1,
                                          isSatisfied,
                                          mtrxList$Installed),,drop=FALSE]

        if (reduce)
            toFind <- reduceDepends(toFind)

        if (length(toFind)) {
            found <- foundDepends(toFind)
            out$Found <- found$Found
            mtrxList$NotFound <- found$NotFound
        }
    }

    if (reduce == TRUE) {       # Found and NotFound are already reduced
        mtrxList$R <- reduceDepends(mtrxList$R)
        mtrxList$Depends <- reduceDepends(mtrxList$Depends)
        mtrxList$Installed <- reduceDepends(mtrxList$Installed)
    }


    ## Massage the matrices back into dependency strings.  out$Found
    ## is already assigned.
    out$R <- depMtrxToStrings(mtrxList$R)
    out$Depends <- depMtrxToStrings(mtrxList$Depends)
    out$Installed <- depMtrxToStrings(mtrxList$Installed)
    out$NotFound <- depMtrxToStrings(mtrxList$NotFound)

    out
}

isSatisfied <- function(dep, instMtrx) {
    triplets <- apply(instMtrx, 1L, paste, collapse=":")
    match(paste(dep,collapse=":"), triplets, nomatch=0L) > 0L
}

buildDepList <- function(depMtrx, instPkgs, recursive=TRUE,
                         lib.loc=NULL) {
    mtrxList <- list(Depends=matrix(nrow=0L,ncol=3L),
                     Installed=matrix(nrow=0L,ncol=3L), R=matrix(nrow=0L,ncol=3L))


    ## First check to see if there is a dependency on R
    ## If there is, then check it
    whichR <- which(depMtrx[,1] == "R")
    if (length(whichR)) {
        mtrxList$R <- depMtrx[whichR,,drop=FALSE]
        depMtrx <- depMtrx[-whichR,,drop=FALSE]
    }

    ## Get which of the direct depends are installed
    instDeps <- depMtrx[installedDepends(depMtrx, instPkgs),,drop=FALSE]

    if (recursive == TRUE) {
        mtrxList$Depends <- depMtrx
        mtrxList$Installed <- instDeps

        for (curPkg in depMtrx[,1]) {
            depMtrx <- getDepMtrx(curPkg, instPkgs)
            ## Make sure this package was found & has deps
            if ((is.null(depMtrx))||(is.na(depMtrx)))
                next

            curMtrxList <- buildDepList(depMtrx, instPkgs,
                                             recursive=recursive,
                                             lib.loc=lib.loc)
            mtrxList$R <- rbind(mtrxList$R, curMtrxList$R)
            mtrxList$Depends <- rbind(mtrxList$Depends,
                                      curMtrxList$Depends)
            mtrxList$Installed <- rbind(mtrxList$Installed,
                                        curMtrxList$Installed)
        }
    }
    else {                              # recurse is FALSE
        mtrxList$Depends <- depMtrx
        mtrxList$Installed <- instDeps
    }

    mtrxList
}

getDepMtrx <- function(pkg, instPkgs, local=TRUE) {

    ## Need to see if pkg is installed - if not, get online
    row <- match(pkg,instPkgs[,"Package"])
    if (!is.na(row))                    # package is installed
        pkgDeps <- package.dependencies(instPkgs[row,])[[1L]]
    else {
        if (local)
            pkgDeps <- NULL
        else
            pkgDeps <- getRemotePkgDepends(pkg)
    }

    pkgDeps        # Either a matrix, NA if no deps or NULL if not found
}

getRemotePkgDepends <- function(pkg, contriburl=getOption("repos")) {
    ## Will get the dependencies of a package from
    ## online repositories.  Returns NULL if it
    ## cannot be found, otherwise returns the row provided
    ## by available.packages().

    if(is.null(contriburl))
        contriburl <- utils::contrib.url(getOption("repos"))

    cran <- utils::available.packages(contriburl=contriburl)
    whichRow <- which(pkg == cran[,"Package"])
    if (length(whichRow)) {
        return(package.dependencies(cran[whichRow,])[[1L]])
    }
    else
        NULL
}

installedDepends <- function(depMtrx, instPkgs) {
    ## Given a matrix of packages, will return a vector of row
    ## numbers that correspond to packages in the matrix where
    ## the dependency is met by installed packages

    pkgs <- depMtrx[,1]
    passPkgs <- character()
    if (length(pkgs)) {
        installed <- (match(pkgs, instPkgs[,"Package"], nomatch=0L) > 0L)

        curPkgs <- depMtrx[installed,,drop=FALSE]
        if (nrow(curPkgs)) {
            passVersReq <- apply(curPkgs, 1L, function(x) {
                pkgVers <- instPkgs[instPkgs[,1]==x[1L],"Version"]
                if (is.na(x[2L])||
                    (compareDependsPkgVersion(pkgVers,
                                              x[2L], x[3L]) >= 0))
                    TRUE
                else
                    FALSE
            })
            passPkgs <- c(passPkgs,curPkgs[passVersReq,1])

            return(which(match(depMtrx[,1],passPkgs,nomatch=0L) > 0L))
        }
    }

    return(numeric())
}

foundDepends <- function(depMtrx, contriburl=getOption("repos")) {
    out <- list(Found=list())
    foundRows <- numeric()

    if(is.null(contriburl))
        contriburl <-
            utils::contrib.url(c(CRAN = getOption("repos")["CRAN"],
                                 BIOC = getOption("BIOC")))


    for (j in seq_along(contriburl)) {
        cur <- character()
        cran <- utils::available.packages(contriburl=contriburl[j])

        if (nrow(depMtrx) > 0) {
            for (i in 1L:nrow(depMtrx)) {
                found <- FALSE
                cranRow <- which(depMtrx[i,1] == cran[,1])
                if (length(cranRow)) {
                    ## Found it in repos
                    if (is.na(depMtrx[i,2])) # no version, automatically okay
                        found <- TRUE
                    else if(compareDependsPkgVersion(cran[cranRow, "Version"],
                                                     depMtrx[i,2],
                                                     depMtrx[i,3]))
                        found <- TRUE
                }
                if (found) {
                    foundRows <- c(foundRows,i)
                    cur <- c(cur,depMtrx[i,1])
                }
            }
        }

        if (length(cur))
            out$Found[contriburl[j]] <- cur
    }

    if (length(foundRows) != nrow(depMtrx))
        out$NotFound <- depMtrx[-foundRows,,drop=FALSE]

    out
}

compareDependsPkgVersion <- function(curVersion, versOper, versionReq) {
    ## Returns -1 if FALSE, 0 or 1 if TRUE
    if(versOper == ">=")
        return(utils::compareVersion(curVersion, versionReq))
    if(versOper == "<=")
        return(utils::compareVersion(versionReq, curVersion))
    else
        stop("bad operand")
}

reduceDepends <- function(depMtrx, quietly=TRUE) {
    if ((is.null(depMtrx))||nrow(depMtrx)==0)
        return(character())

    pkgList <- split(depMtrx, depMtrx[,1])
    out <- lapply(pkgList, function(x, quietly) {
        pkgMtrx <- matrix(x,ncol=3L)
        ## there are no version requirements so just return
        ## the pkg name
        if (all(is.na(pkgMtrx[,2])))
            outRow <- 1
        else {
            ## Have version requirements
            ## Get the maximum ">=" requirement if one exists
            gts <- pkgMtrx[pkgMtrx[,2] == ">=",,drop=FALSE]
            if (nrow(gts) > 0) {
               maxGts <- gts[1,3]
               outRow <- 1
               for (i in 1L:nrow(gts)) {
                   if (utils::compareVersion(gts[i,3], maxGts) > 0) {
                       maxGts <- gts[i,3]
                       outRow <- i
                   }
               }
            }

            ## Find the minimal <= requirement if one exists
            lts <- pkgMtrx[pkgMtrx[,2] == "<=",,drop=FALSE]
            if (nrow(lts) > 0) {
                minLts <- lts[1,3]
                minRow <- 1
                for (i in 1L:nrow(lts)) {
                    if (utils::compareVersion(lts[i,3], minLts) < 0) {
                        minLts <- lts[i,3]
                        minRow <- i
                    }
                }
                ## If there is a maxGts and it is larger then
                ## the minLts then we need to record both
                if (exists(maxGts))
                    if (maxGts > minLts)
                        outRow <- c(outRow, minRow)
                else
                    outRow <- minRow
            }
            if(quietly == FALSE)
                warning(gettextf("Package '%s' had its dependencies reduced to a minimal set.",
                                 pkgMtrx[1,]),
                        domain = NA)
        }
	pkgMtrx[outRow,]
    }, quietly)

    matrix(unlist(out), ncol=3L, byrow=TRUE)
}

depMtrxToStrings <- function(depMtrx) {
    if (length(depMtrx)) {
        apply(depMtrx, 1L, function(x){
            if (is.na(x[2L]))
                x[1L]
            else
                paste0(x[1L]," (",x[2L]," ",x[3L],")")
        })
    }
    else
        character()
}

installFoundDepends <- function(depPkgList, ...) {
    urls <- names(depPkgList)
    for (i in seq_along(depPkgList)) {
        if (length(depPkgList[[i]]))
            utils::install.packages(depPkgList[[i]],
                                    contriburl = urls[i],
                                    ...)
    }

    NULL
}
#  File src/library/tools/R/read.00Index.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2012 The R 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 of the License, 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/

read.00Index <-
function(file)
{
    if(is.character(file)) {
        if(file == "") file <- stdin()
        else {
            file <- file(file, "r")
            on.exit(close(file))
        }
    }
    if(!inherits(file, "connection"))
        stop(gettextf("argument '%s' must be a character string or connection",
                      file),
             domain = NA)

    y <- matrix("", nrow = 0L, ncol = 2L)
    x <- paste(readLines(file), collapse = "\n")

    ## <FIXME>
    ## We cannot necessarily assume that the 00Index-style file to be
    ## read in was generated by @code{Rdindex()} or by R using
    ## formatDL(style = "table").  In particular, some packages have
    ## 00Index files with (section) headers and footers in addition to
    ## the data base chunks which are description lists rendered in
    ## tabular form.  Hence, we need some heuristic for identifying the
    ## db chunks.  Easy to the human eye (is there a column for aligning
    ## entries?) but far from trivial ... as a first approximation we
    ## try to consider chunks containing at least one tab or three
    ## spaces a db chunk.  (A better heuristic would be the following:
    ## entries rendered in one line have item and description separated
    ## by at least 3 spaces or tabs; entries with a line break have
    ## continuation lines starting with whitespace (no test whether for
    ## alignment).  If a chunk is made of such entries only it is
    ## considered a db chunk.  But not all current packages follow this
    ## scheme.  Argh.)
    ## Clearly we need to move to something better in future versions.
    ## </FIXME>

    ## First split into paragraph chunks separated by whitespace-only
    ## lines.
    for(chunk in unlist(strsplit(x, "\n[ \t\n]*\n"))) {
        entries <- tryCatch({
            if(!grepl("(   |\t)", chunk))
                NULL
            else {
                ## Combine entries with continuation lines.
                chunk <- gsub("\n[ \t]+", "\t", chunk)
                ## Split into lines and then according to whitespace.
                x <- strsplit(unlist(strsplit(chunk, "\n")), "[ \t]")
                cbind(unlist(lapply(x, "[[", 1L)),
                      unlist(lapply(x, function(t) {
                          paste(t[-c(1L, which(!nzchar(t)))],
                                collapse = " ")
                      })))
            }
        },
                            error = identity)
        if(!inherits(entries, "error") && NCOL(entries) == 2L)
            y <- rbind(y, entries)
    }
    colnames(y) <- c("Item", "Description")
    y
}
#  File src/library/tools/R/recode.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2012 The R 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 of the License, 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/

### Remap a character string from encoded text to LaTeX escapes
encoded_text_to_latex <-
    function(x, encoding = c("latin1", "latin2", "latin9", "UTF-8", "utf8"))
{
    encoding <- match.arg(encoding)
    do_latin1 <- function(x) {
        xx <- charToRaw(x)
        paste(latin1table[as.integer(xx)], collapse="")}
    do_latin2 <- function(x) {
        xx <- charToRaw(x)
        paste(latin2table[as.integer(xx)], collapse="")}
    do_latin9 <- function(x) {
        xx <- charToRaw(x)
        paste(latin9table[as.integer(xx)], collapse="")}
    do_utf8 <- function(x) {
        xx <- utf8ToInt(x)
        y <- rep("?", length(x))
        y[xx < 512] <- utf8table[xx]
        y[xx == 0x02C6] <- "{\\textasciicircum}"
        y[xx == 0x02C7] <- "{\\textasciicaron}"
        y[xx == 0x02CA] <- "{\\textasciitilde}"
        y[xx == 0x02D8] <- "{\\textasciibreve}"
        y[xx == 0x02D9] <- "{\\textperiodcentered}"
        y[xx == 0x02DD] <- "{\\textacutedbl}"
        y[xx == 0x200C] <- "{\\textcompwordmark}"
        y[xx == 0x2018] <- "{\\textquoteleft}"
        y[xx == 0x2019] <- "{\\textquoteright}"
        y[xx == 0x201C] <- "{\\textquotedblleft}"
        y[xx == 0x201D] <- "{\\textquotedblright}"
        y[xx == 0x2020] <- "{\\textdagger}"
        y[xx == 0x2022] <- "{\\textbullet}"
        y[xx == 0x2026] <- "{\\textellipsis}"
        y[xx == 0x20AC] <- "{\\texteuro}"
        paste(y, collapse="")
    }
    as.vector(switch(encoding,
                     "latin1" = sapply(x, do_latin1),
                     "latin2" = sapply(x, do_latin2),
                     "latin9" = sapply(x, do_latin9),
                     "UTF-8"  = sapply(x, do_utf8),
                     "utf8"   = sapply(x, do_utf8),
                     stop("unimplemented encoding")
                        ))
}

latin1table <- c(
     rep("?", 31), ## omit 0x0
     ## 0x20 to %x7F
     rawToChar(as.raw(seq(32, 126)), multiple=TRUE), "?",
     ## 0x80 to 0x9F
     rep("?", 32),
     ## 0xA0 = 160 on
     "{\\nobreakspace}", "{\\textexclamdown}", "{\\textcent}", "{\\textsterling}", "{\\textcurrency}", "{\\textyen}", "{\\textbrokenbar}", "{\\S}",
     '\\"{}', "{\\textcopyright}", "{\\textordfeminine}", "{\\guillemotleft}", "{\\textlnot}", "\\-", "{\\textregistered}", "{\\a={}}",
     "{\\textdegree}", "{\\textpm}", "{\\mathtwosuperior}", "{\\maththreesuperior}", "{\\a'{}}", "{\\textmu}", "{\\P}", "{\\textperiodcentered}",
     "{\\c\\ }", "{\\mathonesuperior}", "{\\textordmasculine}", "{\\guillemotright}", "{\\textonequarter}", "{\\textonehalf}", "{\\textthreequarters}", "{\\textquestiondown}",
     "{\\a`A}", "{\\a'A}", "{\\^A}", "{\\~A}", '{\\"A}', "{\\r A}", "{\\AE}", "{\\c C}",
     "{\\a`E}", "{\\a'E}", "{\\^E}", "{\\a`I}", "{\\a'I}", "{\\^I}", "{\\~I}", '{\\"I}',
     "{\\DH}", "{\\~N}", "{\\a`O}", "{\\a'O}", "{\\^O}", "{\\~O}", '{\\"O}', "{\\texttimes}",
     "{\\O}", "{\\a`U}", "{\\a'U}", "{\\^U}", '{\\"U}', "{\\a`Y}", "{\\TH}", "{\\ss}",
     "{\\a`a}", "{\\a'a}", "{\\^a}", "{\\~a}", '{\\"a}', "{\\r a}", "{\\ae}", "{\\c c}",
     "{\\a`e}", "{\\a'e}", "{\\^e}", '{\\"e}',"{\\a`\\i}", "{\\a'\\i}", "{\\^\\i}", '{\\"\\i}',
     "{\\dh}", "{\\~n}", "{\\a`o}", "{\\a'o}", "{\\^o}", "{\\~o}", '{\\"o}', "{\\textdiv}",
     "{\\o}", "{\\a`u}", "{\\a'u}", "{\\^u}", '{\\"u}', "{\\a`y}", "{\\th}", '{\\"y}'
     )

latin2table <- c(
     rep("?", 31), ## omit 0x0
     ## 0x20 to %x7F
     rawToChar(as.raw(seq(32, 126)), multiple=TRUE), "?",
     ## 0x80 to 0x9F
     rep("?", 32),
     ## 0xA0 = 160 on
     "{\\nobreakspace}", "{\\k A}", "{\\u{}}", "{\\L}", "{\\textcurrency}", "{\\v L}", "{\\a'S}", "{\\S}",
     '\\"{}', "{\\v S}", "{\\c S}", "{\\v T}", "{\\\'Z}", "\\-", "{\\v Z}", "{\\.Z}",
     "{\\textdegree}", "{\\k A}", "{\\k\\ }", "{\\l}", "{\\a'{}}", "{\\v l}", "{\\a's}", "{\\v{}}",
     "{\\c\\ }", "{\\v s}", "{\\c s}", "{\\v t}", "{\\'z}", "{\\H{}}", "{\\v z}", "{\\.z}",
     "{\\a'R}", "{\\a'A}", "{\\^A}", "{\\u A}", '{\\"A}', "{\\'L}", "{\\a'C}", "{\\c C}",
     "{\\v C}", "{\\a'E}", "{\\k E}", '{\\"E}', "{\\v E}", "{\\'I}", "{\\^I}", '{\\v D}',
     "{\\DJ}", "{\\a'N}", "{\\v N}", "{\\a'O}", "{\\^O}", "{\\H O}", '{\\"O}', "{\\texttimes}",
     "{\\v R}", "{\\r U}", "{\\a'U}", "{\\H U}", '{\\"U}', "{\\a`Y}", "{\\c I}", "{\\ss}",
     "{\\a'r}", "{\\a'a}", "{\\^a}", "{\\u a}", '{\\"a}', "{\\'l}", "{\\a'c}", "{\\c c}",
     "{\\v c}", "{\\a'e}", "{\\k e}", '{\\"e}', "{\\v e}", "{\\'\\i}", "{\\^\\i}", '{\\v d}',
     "{\\dj}", "{\\a'n}", "{\\c n}", "{\\a'o}", '{\\"a}', "{\\H o}", '{\\"o}', "{\\textdiv}",
     "{\\v r}", "{\\r u}", "{\\a'u}", "{\\H u}", '{\\"u}', "{\\a`y}", "{\\c t}", '{\\.{}}'
     )

latin9table <- c(
     rep("?}", 31),
     ## 0x20 to %x7F
     rawToChar(as.raw(seq(32, 126)), multiple=TRUE), "?}",
     ## 0x80 to 0x9F
     rep("?}", 32),
     ## 0xA0 = 160 on
     "{\\nobreakspace}", "{\\textexclamdown}", "{\\textcent}", "{\\textsterling}", "{\\texteuro}", "{\\textyen}", "{\\v S}", "{\\S}",
     '{\\v s}', "{\\copyright}", "{\\textordfeminine}", "{\\guillemotleft}", "{\\textlnot}", "\\-", "{\\textregistered}", "{\\a={}}",
     "{\\textdegree}", "{\\textpm}", "{\\mathtwosuperior}", "{\\maththreesuperior}", "{\\v Z}", "{\\textmu}", "{\\P}", "{\\textperiodcentered}",
     "{\\v z}", "{\\mathonesuperior}", "{\\textordmasculine}", "{\\guillemotright}", "{\\OE}", "{\\oe}", '{\\"Y}', "{\\textquestiondown}",
     "{\\a`A}", "{\\a'A}", "{\\^A}", "{\\~A}", '{\\"A}', "{\\r A}", "{\\AE}", "{\\c C}",
     "{\\a`E}", "{\\a'E}", "{\\^E}", "{\\a`I}", "{\\a'I}", "{\\^I}", "{\\~I}", '{\\"I}',
     "{\\DH}", "{\\~N}", "{\\a`O}", "{\\a'O}", "{\\^O}", "{\\~O}", '{\\"O}', "{\\texttimes}",
     "{\\O}", "{\\a`u}", "{\\a'U}", "{\\^U}", '\\"U', "{\\a`Y}", "{\\TH}", "{\\ss}",
     "{\\a`a}", "{\\a'a}", "{\\^a}", "{\\~a}", '{\\"a}', "{\\r a}", "{\\ae}", "{\\c c}",
     "{\\a`e}", "{\\a'e}", "{\\^e}", '{\\"e}',"{\\a`\\i}", "{\\a'\\i}", "{\\^\\i}", '{\\"\\i}',
     "{\\dh}", "{\\~n}", "{\\a`o}", "{\\a'o}", "{\\^o}", "{\\~o}", '{\\"o}', "{\\textdiv}",
     "{\\o}", "{\\a`u}", "{\\a'u}", "{\\^u}", '\\"u', "{\\a`y}", "{\\th}", '{\\"y}'
     )

utf8table <- c(latin1table, rep("?", 256))

utf8table[0x0102:0x107] <-
    c("{\\u A}","{\\u a}", "{\\k A}", "{\\k a}", "{\\a'C}", "{\\a'c}")
utf8table[0x010C:0x111] <-
    c( "{\\v C}","{\\v c}","{\\v D}","{\\v d}","{\\DJ}","{\\dj}")

utf8table[0x0118:0x11B] <- c("{\\k E}","{\\k e}", "{\\v E}","{\\v e}")
utf8table[0x011E:0x11F] <- c("{\\u G}","{\\u g}")
utf8table[0x0130:0x131] <- c("{\\.I}","{\\i}")
utf8table[0x0139:0x13A] <- c("{\\a'L}","{\\a'l}")
utf8table[0x013D:0x13E] <- c("{\\v L}","{\\v l}")
utf8table[0x0141L:0x144] <- c("{\\L}","{\\l}","{\\a'N}","{\\a'n}")
utf8table[0x0147:0x14B] <- c("{\\v N}","{\\v n}","?","{\\NG}","{\\ng}")
utf8table[0x0150:0x155] <- c("{\\H O}","{\\H o}","{\\OE}","{\\oe}","{\\a'R}","{\\a'r}")
utf8table[0x0158:0x15B] <- c("{\\v R}","{\\v r}","{\\a'S}","{\\a's}")
utf8table[0x015E:0x165] <- c("{\\c S}","{\\c s}","{\\v S}","{\\v s}",
                             "{\\c T}","{\\c t}","{\\v T}","{\\v t}")
utf8table[0x016E:0x171] <- c("{\\r U}","{\\r u}","{\\H U}","{\\H u}")
utf8table[0x0178:0x17E] <- c('{\\"Y}',"{\\a'Z}","{\\a'z}","{\\.Z}", "{\\.z}","{\\v Z}","{\\v z}")
utf8table[0x0192] <- "{\\textflorin}"
#  File src/library/tools/R/sotools.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 2011-2013 The R 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 of the License, 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/

if(.Platform$OS.type == "windows") {
    read_symbols_from_dll <- function(f, rarch)
    {
        ## reasonable to assume this on the path
        DLL_nm <- "objdump.exe"
        if(!nzchar(Sys.which(DLL_nm))) return()
        f <- file_path_as_absolute(f)
        s0 <- suppressWarnings(system2(DLL_nm, c("-x", shQuote(f)),
                                       stdout = TRUE, stderr = TRUE))
        status <- attr(s0, "status")
        if (length(status) && status != 0) return()
        l1 <- grep("^\tDLL Name:", s0)
        l2 <- grep("^The Export Tables", s0)
        if (!length(l1) || !length(l2)) return()
        s1 <- s0[(l1[1L] + 3L):(l2 - 4L)]
        s2 <- grep("\t[0-9a-f]+\t +[0-9]+", s1, value = TRUE)
        sub(".* ([_A-Za-z0-9]+)$", "\\1", s2)
    }
}

read_symbols_from_object_file <- function(f)
{
    ## reasonable to assume this on the path
    if(!nzchar(nm <- Sys.which("nm"))) return()
    f <- file_path_as_absolute(f)
    if(!(file.info(f)$size)) return()
    s <- strsplit(system(sprintf("%s -Pg %s", shQuote(nm), shQuote(f)),
                         intern = TRUE),
                  " +")
    ## Cannot simply rbind() this because elements may have 2-4
    ## entries.
    n <- length(s)
    tab <- matrix("", nrow = n, ncol = 4L)
    colnames(tab) <- c("name", "type", "value", "size")
    ## Compute desired i and j positions in tab.
    i <- rep.int(seq_len(n), sapply(s, length))
    j <- unlist(lapply(s, seq_along))
    tab[n * (j - 1L) + i] <- unlist(s)
    tab
}

get_system_ABI <- if(.Platform$OS.type == "windows") {
    function() c(system = "windows", CC = "gcc", CXX = "g++",
                 F77 = "gfortran", FC = "gfortran")
} else {
    function()
    {
        s <- Sys.getenv("R_SYSTEM_ABI")
        if((s == "") || (substring(s, 1L, 1L) %in% c("@", "?")))
            return(character())
        s <- unlist(strsplit(s, ",", fixed = TRUE))
        names(s) <- c("system", "CC", "CXX", "F77", "FC")
        s
    }
}

system_ABI <- get_system_ABI()

so_symbol_names_table <-
    c("linux, C, gcc, abort, abort",
      ## http://refspecs.freestandards.org/LSB_4.0.0/LSB-Core-generic/LSB-Core-generic/baselib---assert-fail-1.html
      "linux, C, gcc, assert, __assert_fail",
      "linux, C, gcc, exit, exit",
      "linux, C, gcc, printf, printf",
      "linux, C, gcc, printf, puts",
      "linux, C, gcc, puts, puts",
      "linux, C, gcc, putchar, putchar",
      "linux, C, gcc, stderr, stderr",
      "linux, C, gcc, stdout, stdout",
      "linux, C, gcc, vprintf, vprintf",
      "linux, C++, gxx, std::cout, _ZSt4cout",
      "linux, C++, gxx, std::cerr, _ZSt4cerr",
      ## libcxx variants
      "linux, C++, gxx, std::cout, _ZNSt3__14coutE",
      "linux, C++, gxx, std::cerr, _ZNSt3__14cerrE",
      "linux, Fortran, gfortran, write, _gfortran_st_write",
      "linux, Fortran, gfortran, print, _gfortran_st_write",
      "linux, Fortran, gfortran, stop, _gfortran_stop_numeric_f08",
      "linux, Fortran, gfortran, stop, _gfortran_stop_string",

      "osx, C, gcc, abort, _abort",
      "osx, C, gcc, assert, ___assert_rtn",
      "osx, C, gcc, exit, _exit",
      "osx, C, gcc, printf, _printf",
      "osx, C, gcc, printf, _puts",
      "osx, C, gcc, puts, _puts",
      "osx, C, gcc, putchar, _putchar",
      "osx, C, gcc, stderr, ___stderrp",
      "osx, C, gcc, stdout, ___stdoutp",
      "osx, C, gcc, vprintf, _vprintf",
      "osx, C++, gxx, std::cout, __ZSt4cout",
      "osx, C++, gxx, std::cerr, __ZSt4cerr",
      ## libcxx variants
      "osx, C++, gxx, std::cout, __ZNSt3__14coutE",
      "osx, C++, gxx, std::cerr, __ZNSt3__14cerrE",
      "osx, Fortran, gfortran, write, __gfortran_st_write",
      "osx, Fortran, gfortran, print, __gfortran_st_write",
      "osx, Fortran, gfortran, stop, __gfortran_stop_numeric",
      "osx, Fortran, gfortran, stop, __gfortran_stop_string",

      "freebsd, C, gcc, abort, abort",
      "freebsd, C, gcc, assert, __assert",
      "freebsd, C, gcc, exit, exit",
      "freebsd, C, gcc, printf, printf",
      "freebsd, C, gcc, printf, puts",
      "freebsd, C, gcc, puts, puts",
      "freebsd, C, gcc, putchar, putchar",
      "freebsd, C, gcc, stderr, __stderrp",
      "freebsd, C, gcc, stdout, __stdoutp",
      "freebsd, C, gcc, vprintf, vprintf",
      "freebsd, C++, gxx, std::cout, _ZSt4cout",
      "freebsd, C++, gxx, std::cerr, _ZSt4cerr",
      "freebsd, Fortran, gfortran, write, _gfortran_st_write",
      "freebsd, Fortran, gfortran, print, _gfortran_st_write",
      "freebsd, Fortran, gfortran, stop, _gfortran_stop_numeric_f08",
      "freebsd, Fortran, gfortran, stop, _gfortran_stop_string",

      ## stdout, stderr do not show up on Solaris
      "solaris, C, solcc, abort, abort",
      "solaris, C, solcc, assert, __assert_c99",
      "solaris, C, solcc, exit, exit",
      "solaris, C, solcc, printf, printf",
      "solaris, C, solcc, putchar, putchar",
      "solaris, C, solcc, puts, puts",
      "solaris, C, solcc, vprintf, vprintf",
      "solaris, C++, solCC, std::cout, __1cDstdEcout_",
      "solaris, C++, solCC, std::cerr, __1cDstdEcerr_",
      "solaris, Fortran, solf95, print, __f90_eslw",
      "solaris, Fortran, solf95, write, __f90_eslw",
      "solaris, Fortran, solf95, print, __f90_esfw",
      "solaris, Fortran, solf95, write, __f90_esfw",
      "solaris, Fortran, solf95, write, __f90_esuw",
      "solaris, Fortran, solf95, stop, __f90_stop",
      "solaris, Fortran, solf95, stop, __f90_stop_int",
      "solaris, Fortran, solf95, stop, __f90_stop_char",
      "solaris, Fortran, solf95, runtime, abort",

      ## Windows statically links libstdc++, libgfortran
      ## only in .o, positions hard-coded in check_so_symbols
      "windows, C++, g++, std::cout, _ZSt4cout",
      "windows, C++, g++, std::cerr, _ZSt4cerr",
      "windows, Fortran, gfortran, write, _gfortran_st_write",
      "windows, Fortran, gfortran, print, _gfortran_st_write",
      ## in DLL
      "windows, C, gcc, abort, abort",
      "windows, C++, gxx, runtime, abort",
      "windows, Fortran, gfortran, runtime, abort",
      "windows, C, gcc, assert, _assert",
      "windows, C, gcc, exit, exit",
      "windows, C, gcc, printf, printf",
      "windows, C, gcc, printf, puts",
      "windows, C, gcc, puts, puts",
      "windows, C, gcc, putchar, putchar",
      "windows, C, gcc, vprintf, vprintf",
      "windows, Fortran, gfortran, stop, exit"
      )
so_symbol_names_table <-
    do.call(rbind,
            strsplit(so_symbol_names_table,
                     split = ", ", fixed = TRUE))
colnames(so_symbol_names_table) <-
    c("system", "language", "compiler", "ssname", "osname")

## Subscript according to system and compiler types here, rather than
## repeatedly doing this at run time.
so_symbol_names_table <-
    so_symbol_names_table[(so_symbol_names_table[, "system"] ==
                           system_ABI["system"]) &
                          (so_symbol_names_table[, "compiler"] %in%
                           system_ABI[c("CC", "CXX", "F77", "FC")]),
                          c("language", "ssname", "osname"),
                          drop = FALSE]

so_symbol_names_handlers_db <- list()
## <NOTE>
## As we record the low-level (possibly mangled) symbol names for
## each system/compiler combination, there is no need for handlers to
## demangle into user-level names (e.g., using c++filt).
## </NOTE>
so_symbol_names_handlers_db$linux <-
function(x)
{
    ## Linux ELF symbol versioning, see
    ##  http://lists.debian.org/lsb-spec/1999/12/msg00017.html:
    ## name@version for alternatives, name@@version for the default.
    sub("@.*", "", x)
}

so_symbol_names_handlers_db$freebsd <-
function(x)
{
    ## same as Linux, most likely, lots of name@@VERSION
    sub("@.*", "", x)
}

## Obsolete ones first,
nonAPI <- c("chol_", "chol2inv_", "cg_", "ch_", "rg_",
            "fft_factor", "fft_work", "Brent_fmin", "optif0",

## then entry points which are not attribute-hidden
## and in a non-API header or no header at all.

            "OutDec", "PRIMOFFSET", "RC_fopen", "R_CollectFromIndex",
            "R_CompiledFileName", "R_FileExists",
            "R_FreeStringBuffer", "R_FunTab", "R_GE_setVFontRoutines",
            "R_GetVarLocMISSING", "R_MakeExternalPtrFn",
            "R_MethodsNamespace", "R_NewHashedEnv",
            "R_OpenCompiledFile", "R_PV", "R_ParseContext",
            "R_ParseContextLast", "R_ParseContextLine",
            "R_ParseError", "R_ParseErrorMsg", "R_SrcfileSymbol",
            "R_SrcrefSymbol", "R_Visible", "R_addTaskCallback",
            "R_cairoCdynload", "R_data_class",
            "R_deferred_default_method", "R_execMethod",
            "R_findVarLocInFrame","R_fopen", "R_gc_torture",
            "R_getTaskCallbackNames", "R_get_arith_function",
            "R_gzclose", "R_gzgets", "R_gzopen", "R_ignore_SIGPIPE",
            "R_isForkedChild", "R_isMethodsDispatchOn",
            "R_moduleCdynload", "R_primitive_generic",
            "R_primitive_methods", "R_print", "R_removeTaskCallback",
            "R_running_as_main_program", "R_setInternetRoutines",
            "R_setLapackRoutines", "R_setX11Routines",
            "R_set_prim_method", "R_set_quick_method_check",
            "R_set_standardGeneric_ptr", "R_strtod4",
            "R_subassign3_dflt", "R_taskCallbackRoutine",
            "Rconn_fgetc", "Rconn_printf", "Rdownload",
            "Rf_EncodeComplex", "Rf_EncodeElement",
            "Rf_EncodeEnvironment", "Rf_EncodeInteger",
            "Rf_EncodeLogical", "Rf_EncodeReal", "Rf_GPretty",
            "Rf_NewEnvironment", "Rf_PrintDefaults",
            "Rf_ReplIteration", "Rf_Seql", "Rf_addTaskCallback",
            "Rf_begincontext", "Rf_callToplevelHandlers",
            "Rf_checkArityCall", "Rf_con_pushback",
            "Rf_copyMostAttribNoTs", "Rf_deparse1", "Rf_deparse1line",
            "Rf_dpptr", "Rf_endcontext", "Rf_envlength",
            "Rf_formatComplex", "Rf_formatInteger",
            "Rf_formatLogical", "Rf_formatReal", "Rf_init_con",
            "Rf_isProtected", "Rf_mbrtowc", "Rf_mkFalse",
            "Rf_printNamedVector", "Rf_printRealVector",
            "Rf_printVector", "Rf_removeTaskCallbackByIndex",
            "Rf_removeTaskCallbackByName", "Rf_set_iconv",
            "Rf_sortVector", "Rf_strIsASCII", "Rf_strchr",
            "Rf_strrchr", "Rf_ucstomb", "Rf_utf8towcs",
            "Rf_wcstoutf8", "Rg_PolledEvents", "Rg_set_col_ptrs",
            "Rg_wait_usec", "Ri18n_iswctype", "Ri18n_wcswidth",
            "Ri18n_wctype", "Ri18n_wcwidth", "Rsockclose",
            "Rsockconnect", "Rsocklisten", "Rsockopen", "Rsockread",
            "Rsockwrite", "Runzip", "UNIMPLEMENTED_TYPE",
            "baseRegisterIndex", "csduplicated", "currentTime",
            "dcar", "dcdr", "do_Rprof", "do_Rprofmem", "do_X11",
            "do_contourLines", "do_edit", "do_getGraphicsEventEnv",
            "do_getSnapshot", "do_playSnapshot", "do_saveplot",
            "do_set_prim_method", "dqrrsd_","dqrxb_", "dtype",
            "dummy_fgetc", "dummy_ii", "dummy_vfprintf", "epslon_",
            "extR_HTTPDCreate", "extR_HTTPDStop", "fdhess",
            "getConnection", "getPRIMNAME", "known_to_be_latin1",
            "locale2charset", "match5", "matherr",
            "max_contour_segments", "mbcsToUcs2", "memtrace_report",
            "parseError", "pythag_", "rs_", "rwarnc_",
            "signrank_free", "tql2_", "tqlrat_", "tred1_", "tred2_",
            "utf8locale", "wilcox_free", "yylloc",

## Rinterface.h, Rembedded.h, R_ext/{RStartup,eventloop}.h
            "AllDevicesKilled", "R_CStackLimit", "R_CStackStart",
            "R_ClearerrConsole", "R_CleanTempDir", "R_Consolefile",
            "R_DefParams", "R_DirtyImage", "R_GUIType", "R_GlobalContext",
            "R_HistoryFile", "R_HistorySize", "R_Home", "R_HomeDir",
            "R_InputHandlers", "R_Interactive", "R_Outputfile",
            "R_PolledEvents", "R_ReplDLLdo1", "R_ReplDLLinit",
            "R_RestoreGlobalEnv", "R_RestoreGlobalEnvFromFile",
            "R_RestoreHistory", "R_RunExitFinalizers", "R_SaveGlobalEnv",
            "R_SaveGlobalEnvToFile", "R_SelectEx", "R_SetParams",
            "R_SetWin32", "R_SignalHandlers", "R_SizeFromEnv", "R_Slave",
            "R_Suicide", "R_TempDir", "R_checkActivity",
            "R_checkActivityEx", "R_runHandlers",
            "R_setStartTime", "R_set_command_line_arguments",
            "R_setupHistory", "R_timeout_handler", "R_timeout_val",
            "R_wait_usec", "RestoreAction", "Rf_CleanEd",
            "Rf_KillAllDevices", "Rf_endEmbeddedR", "Rf_initEmbeddedR",
            "Rf_initialize_R", "Rf_jump_to_toplevel", "Rf_mainloop",
            "SaveAction", "addInputHandler", "editorcleanall", "fpu_setup",
            "getDLLVersion", "getInputHandler", "getRUser", "get_R_HOME",
            "getSelectedHandler", "initStdinHandler",
            "process_site_Renviron", "process_system_Renviron",
            "process_user_Renviron", "ptr_R_Busy", "ptr_R_ChooseFile",
            "ptr_R_CleanUp", "ptr_R_ClearerrConsole", "ptr_R_EditFile",
            "ptr_R_EditFiles", "ptr_R_FlushConsole", "ptr_R_ProcessEvents",
            "ptr_R_ReadConsole", "ptr_R_ResetConsole", "ptr_R_ShowFiles",
            "ptr_R_ShowMessage", "ptr_R_Suicide", "ptr_R_WriteConsole",
            "ptr_R_WriteConsoleEx", "ptr_R_addhistory", "ptr_R_loadhistory",
            "ptr_R_savehistory", "ptr_do_dataentry", "ptr_do_dataviewer",
            "ptr_do_selectlist", "readconsolecfg", "removeInputHandler",
            "run_Rmainloop", "setup_Rmainloop")

## non-API in Applic.h
## future <- c("dqrcf_", "dqrdc2_", "dqrls_", "dqrqty_", "dqrqy_", "optif9")
## d1mach_ and i1mach_ are mentioned (since R 2.15.3) in R-exts.

## grDevices uses R_Home R_InputHandlers R_TempDir R_Visible R_cairoCdynload R_fopen R_gzclose R_gzgets R_gzopen R_isForkedChild Rf_envlength Rf_strIsASCII Rf_utf8towcs Rg_set_col_ptrs Ri18n_wcwidth addInputHandler do_X11 do_contourLines do_getGraphicsEventEnv do_getSnapshot do_playSnapshot do_saveplot locale2charset mbcsToUcs2 ptr_R_ProcessEvents

## graphics uses OutDec R_print Rf_EncodeComplex Rf_EncodeInteger Rf_EncodeLogical Rf_EncodeReal Rf_GPretty Rf_PrintDefaults Rf_envlength Rf_formatComplex Rf_formatReal baseRegisterIndex known_to_be_latin1 max_contour_segments

## methods uses R_GetVarLocMISSING R_MakeExternalPtrFn R_MethodsNamespace R_data_class R_deferred_default_method R_execMethod R_findVarLocInFrame R_primitive_generic R_primitive_methods R_set_prim_method R_set_quick_method_check R_set_standardGeneric_ptr R_subassign3_dflt Rf_NewEnvironment Rf_envlength do_set_prim_method getPRIMNAME

## parallel uses R_isForkedChild

## stats uses Rf_PrintDefaults Rf_Seql Rf_copyMostAttribNoTs Rf_deparse1 Rf_deparse1line Rf_envlength Rf_mkFalse fdhess memtrace_report signrank_free wilcox_free

## tcltk uses R_Consolefile R_GUIType R_InputHandlers R_Outputfile R_PolledEvents R_checkActivity R_runHandlers R_timeout_handler R_timeout_val R_wait_usec ptr_R_ClearerrConsole ptr_R_FlushConsole ptr_R_ReadConsole ptr_R_ResetConsole ptr_R_WriteConsole

## tools uses RC_fopen R_FileExists R_NewHashedEnv R_ParseContext R_ParseContextLast R_ParseContextLine R_ParseError R_ParseErrorMsg R_SrcfileSymbol R_SrcrefSymbol Rconn_fgetc Rf_begincontext Rf_endcontext Rf_envlength Rf_mbrtowc Rf_strchr extR_HTTPDCreate extR_HTTPDStop getConnection parseError

## utils uses R_ClearerrConsole R_FreeStringBuffer R_GUIType R_moduleCdynload R_print R_strtod4 Rconn_fgetc Rconn_printf Rdownload Rf_EncodeElement Rf_PrintDefaults Rf_begincontext Rf_con_pushback Rf_endcontext Rf_envlength Rf_sortVector Rsockclose Rsockconnect Rsocklisten Rsockopen Rsockread Rsockwrite Runzip UNIMPLEMENTED_TYPE csduplicated do_Rprof do_Rprofmem do_edit getConnection known_to_be_latin1 ptr_R_addhistory ptr_R_loadhistory ptr_R_savehistory ptr_do_dataentry ptr_do_dataviewer ptr_do_selectlist

## modules use PRIMOFFSET R_GE_setVFontRoutines R_setInternetRoutines R_setLapackRoutines R_setX11Routines Rf_set_iconv currentTime dummy_fgetc dummy_vfprintf ucstomb utf8locale


check_so_symbols <- if(.Platform$OS.type == "windows") {
    function(so, rarch, have_tables = FALSE)
    {
        if(!length(system_ABI)) return()
        nms <- read_symbols_from_dll(so, rarch)
        ind <- so_symbol_names_table[, "osname"] %in% nms
        if(have_tables) ind[1:4] <- TRUE
        tab <- so_symbol_names_table[ind, , drop = FALSE]
        attr(tab, "file") <- so
        tab2 <- intersect(sub("^_", "", nms), nonAPI)
        if ("removeInputHandler" %in% tab2)
            tab2 <- setdiff(tab2, c("R_InputHandlers", "addInputHandler",
                                    "removeInputHandler"))
        if(length(tab2)) attr(tab, "nonAPI") <- tab2
        class(tab) <- "check_so_symbols"
        tab
    }
} else {
    function(so)
    {
        if(!length(system_ABI)) return()
        tab <- read_symbols_from_object_file(so)
        tab2 <- tab[tab[, "type"] == "U", "name"]
	nms <- tab[, "name"]
        sys <- system_ABI["system"]
        if(!is.null(snh <- so_symbol_names_handlers_db[[sys]]))
            nms <- snh(nms)
        ind <- so_symbol_names_table[, "osname"] %in% nms
        tab <- so_symbol_names_table[ind, , drop = FALSE]
        attr(tab, "file") <- so
        tab2 <- sub("^_", "", tab2)
        tab2 <- intersect(tab2, nonAPI)
        if ("removeInputHandler" %in% tab2)
            tab2 <- setdiff(tab2, c("R_InputHandlers", "addInputHandler",
                                    "removeInputHandler"))
        if(length(tab2)) attr(tab, "nonAPI") <- tab2
        class(tab) <- "check_so_symbols"
        tab
    }
}

format.check_so_symbols <-
function(x, ...)
{
    if(!length(x)) return(character())
    entries <- split.data.frame(x, x[, "osname"])
    objects <- vector("list", length(entries))
    names(objects) <- names(entries)
    if(length(objs <- attr(x, "objects")))
        objects[names(objs)] <- objs
    c(gettextf("File %s:", sQuote(attr(x, "file"))),
      unlist(Map(function(u, v, w)
                 c(strwrap(gettextf("Found %s, possibly from %s",
                                    sQuote(v),
                                    paste(sprintf("%s (%s)",
                                                  sQuote(u[, "ssname"]),
                                                  u[, "language"]),
                                          collapse = ", ")),
                           indent = 2L, exdent = 4L),
                   if(length(w) > 1L) {
                       strwrap(sprintf("Objects: %s",
                                       paste(sQuote(w), collapse =
                                             ", ")),
                               indent = 4L, exdent = 6L)
                   } else if(length(w)) {
                       strwrap(sprintf("Object: %s", sQuote(w)),
                               indent = 4L, exdent = 6L)
                   }),
                 entries, names(entries), objects)))
}

check_compiled_code <-
if(.Platform$OS.type == "windows") {
    function(dir)
    {
        ## Check compiled code in the DLL(s) of an installed package.

        r_arch <- .Platform$r_arch
        useST <- config_val_to_logical(Sys.getenv("_R_SHLIB_BUILD_OBJECTS_SYMBOL_TABLES_", "FALSE"))

        compare <- function(x, strip_ = FALSE) {
            ## Compare symbols in the DLL and in objects:
            symbols <-
                Filter(length,
                       lapply(tables,
                              function(tab) {
                                  nm <- tab[, "name"]
                                  if (strip_) nm <- sub("^_", "", nm)
                                  nm <- sub("_gfortran_stop.*", "exit", nm)
                                  intersect(x[, "osname"], nm)
                              }))
            ## Drop the DLL symbols not in any object.
            so <- attr(x, "file")
            osnames_in_objects <- unique(as.character(unlist(symbols)))
            x <- x[!is.na(match(x[, "osname"], osnames_in_objects)), , drop = FALSE]
            attr(x, "file") <- so

            attr(x, "objects") <-
                split(rep.int(names(symbols), sapply(symbols, length)),
                      unlist(symbols))
            class(x) <- "check_so_symbols"
            x
        }

        so_files <-
            Sys.glob(file.path(dir, "libs/i386",
                               sprintf("*%s", .Platform$dynlib.ext)))
        bad <- if(length(so_files)) {
            objects_symbol_tables_file <-
                file.path(dir, "libs/i386", "symbols.rds")
            if(file_test("-f", objects_symbol_tables_file)) {
                bad <- Filter(length, lapply(so_files, check_so_symbols,
                                             rarch = "i386", have_tables = TRUE))
                tables <- readRDS(objects_symbol_tables_file)
                Filter(length, lapply(bad, compare, strip_ = TRUE))
            } else {
                if(useST)
                    cat("Note: information on .o files for i386 is not available\n")
                Filter(length, lapply(so_files, check_so_symbols, rarch="i386"))
            }
        } else NULL
        nAPIs <- lapply(lapply(so_files, check_so_symbols, rarch = "i386"),
                        function(x) if(length(z <- attr(x, "nonAPI")))
                        structure(z, file = attr(x, "file"),
                                  class = "check_nonAPI_calls"))

        bad <- c(bad, Filter(length, nAPIs))

        so_files <-
            Sys.glob(file.path(dir, "libs/x64",
                               sprintf("*%s", .Platform$dynlib.ext)))
        bad2 <- if(length(so_files)) {
            objects_symbol_tables_file <- file.path(dir, "libs/x64", "symbols.rds")
            if(file_test("-f", objects_symbol_tables_file)) {
                bad2 <- Filter(length, lapply(so_files, check_so_symbols,
                                              rarch = "x64", have_tables = TRUE))
                tables <- readRDS(objects_symbol_tables_file)
                Filter(length, lapply(bad2, compare))
            } else {
                if(useST)
                    cat("Note: information on .o files for x64 is not available\n")
                Filter(length, lapply(so_files, check_so_symbols, rarch="x64"))
            }
        } else NULL
        nAPIs <- lapply(lapply(so_files, check_so_symbols, rarch = "x64"),
                        function(x) if(length(z <- attr(x, "nonAPI")))
                        structure(z, file = attr(x, "file"),
                                  class = "check_nonAPI_calls"))

        bad2 <- c(bad2, Filter(length, nAPIs))

        if(!length(bad) && !length(bad2)) return(invisible(NULL))

        bad <- if(length(bad) && length(bad2)) rbind(bad, bad2)
        else if(length(bad2)) bad2 else bad
        class(bad) <- "check_compiled_code"
        bad
    }
} else {
    function(dir)
    {
        ## Check compiled code in the shared objects of an installed package.

        r_arch <- .Platform$r_arch
        useST <- config_val_to_logical(Sys.getenv("_R_SHLIB_BUILD_OBJECTS_SYMBOL_TABLES_", "FALSE"))

        compare <- function(x) {
            ## Compare symbols in the so and in objects:
            symbols <-
                Filter(length,
                       lapply(tables,
                              function(tab) {
                                  nm <- tab[, "name"]
                                  intersect(x[, "osname"], nm)
                              }))
            ## Drop the so symbols not in any object.
            so <- attr(x, "file")
            ## (Alternatively, provide a subscript method
            ## for class "check_so_symbols".)
            osnames_in_objects <- unique(as.character(unlist(symbols)))
            x <- x[!is.na(match(x[, "osname"], osnames_in_objects)), , drop = FALSE]
            attr(x, "file") <- so
            attr(x, "objects") <-
                split(rep.int(names(symbols), sapply(symbols, length)),
                      unlist(symbols))
            class(x) <- "check_so_symbols"
            x
        }

        so_files <- if(nzchar(r_arch))
            Sys.glob(file.path(dir, "libs", r_arch,
                               sprintf("*%s", .Platform$dynlib.ext)))
        else
            Sys.glob(file.path(dir, "libs",
                               sprintf("*%s", .Platform$dynlib.ext)))
        if(!length(so_files)) return(invisible(NULL)) # typically a fake install

        bad <- Filter(length, lapply(so_files, check_so_symbols))
        objects_symbol_tables_file <- if(nzchar(r_arch))
            file.path(dir, "libs", r_arch, "symbols.rds")
        else file.path(dir, "libs", "symbols.rds")
        if(file_test("-f", objects_symbol_tables_file)) {
            tables <- readRDS(objects_symbol_tables_file)
            bad <- Filter(length, lapply(bad, compare))
        } else if(useST)
            cat("Note: information on .o files is not available\n")
        nAPIs <- lapply(lapply(so_files, check_so_symbols),
                        function(x) if(length(z <- attr(x, "nonAPI")))
                        structure(z, file = attr(x, "file"),
                                  class = "check_nonAPI_calls"))

        bad <- c(bad, Filter(length, nAPIs))
        class(bad) <- "check_compiled_code"
        bad
    }
}

format.check_compiled_code <-
function(x, ...)
{
    if(!length(x)) return(character())
    ## sapply does not always simplify as one wants here if there is
    ## more than one DLL.
    paste(unlist(lapply(x, format)), collapse = "\n")
}

format.check_nonAPI_calls <-
function(x, ...)
{
    if(length(x))
        c(gettextf("File %s:", sQuote(attr(x, "file"))),
          if (length(x) > 1L) {
              strwrap(paste("Found non-API calls to R:",
                            paste(sQuote(x), collapse = ", ")),
                      indent = 2L, exdent = 4L)
          } else paste("  Found non-API call to R:", sQuote(x))
          )
    else character()
}

.shlib_objects_symbol_tables <-
function(file = "symbols.rds")
{
    objects <- commandArgs(trailingOnly = TRUE)
    tables <- lapply(objects, read_symbols_from_object_file)
    names(tables) <- objects
    saveRDS(tables, file = file)
}
#  File src/library/tools/R/testing.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R Core Team
#
# NB: also copyright date in Usage.
#
#  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 of the License, 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/

## functions principally for testing R and packages

massageExamples <-
    function(pkg, files, outFile = stdout(), use_gct = FALSE, addTiming = FALSE)
{
    if(file_test("-d", files[1L])) {
        old <- Sys.setlocale("LC_COLLATE", "C")
        files <- sort(Sys.glob(file.path(files, "*.R")))
        Sys.setlocale("LC_COLLATE", old)
    }

    if(is.character(outFile)) {
        out <- file(outFile, "wt")
        on.exit(close(out))
    } else out <- outFile

    lines <- c(paste0('pkgname <- "', pkg, '"'),
               'source(file.path(R.home("share"), "R", "examples-header.R"))',
               if (use_gct) {
                   gct_n <- as.integer(Sys.getenv("_R_CHECK_GCT_N_", 0))
                   if(!is.na(gct_n) && gct_n > 0L)
                       sprintf("gctorture2(%s)", gct_n)
                   else "gctorture(TRUE)"
               },
               "options(warn = 1)")
    cat(lines, sep = "\n", file = out)
    if(.Platform$OS.type == "windows")
        cat("options(pager = \"console\")\n", file = out)
    if(addTiming) {
        ## adding timings
        cat("base::assign(\".ExTimings\", \"", pkg,
            "-Ex.timings\", pos = 'CheckExEnv')\n", sep="", file = out)
        cat("base::cat(\"name\\tuser\\tsystem\\telapsed\\n\", file=base::get(\".ExTimings\", pos = 'CheckExEnv'))\n", file = out)
        ## a package left OutDec = "," at the end of an example
        cat("base::assign(\".format_ptime\",",
            "function(x) {",
            "  if(!is.na(x[4L])) x[1L] <- x[1L] + x[4L]",
            "  if(!is.na(x[5L])) x[2L] <- x[2L] + x[5L]",
            "  options(OutDec = '.')",
            "  format(x[1L:3L], digits = 7L)",
            "},",
            "pos = 'CheckExEnv')\n", sep = "\n", file = out)
        cat("### * </HEADER>\n", file = out)
    }

    if(pkg == "tcltk") {
        if(capabilities("tcltk")) cat("require('tcltk')\n\n", file = out)
        else cat("q()\n\n", file = out)
    } else if(pkg != "base")
        cat("library('", pkg, "')\n\n", sep = "", file = out)

    cat("base::assign(\".oldSearch\", base::search(), pos = 'CheckExEnv')\n", file = out)
    ## cat("assign(\".oldNS\", loadedNamespaces(), pos = 'CheckExEnv')\n", file = out)
    for(file in files) {
        nm <- sub("\\.R$", "", basename(file))
        ## make a syntactic name out of the filename
        nm <- gsub("[^- .a-zA-Z0-9_]", ".", nm, perl = TRUE, useBytes = TRUE)
        if (pkg == "grDevices" && nm == "postscript") next
        ## Latin-1 examples are treated separat
        if (pkg == "graphics" && nm == "text") next
        if(!file.exists(file))
            stop("file ", file, " cannot be opened", domain = NA)
        lines <- readLines(file)
        have_examples <- any(grepl("_ Examples _|### \\*+ Examples",
                                   lines, perl = TRUE, useBytes = TRUE))
        ## skip comment lines
        com <- grep("^#", lines, perl = TRUE, useBytes = TRUE)
        lines1 <- if(length(com)) lines[-com] else lines
        have_par <- any(grepl("[^a-zA-Z0-9.]par\\(|^par\\(",
                                lines1, perl = TRUE, useBytes = TRUE))
        have_contrasts <- any(grepl("options\\(contrasts",
                                   lines1, perl = TRUE, useBytes = TRUE))

        if(have_examples)
            cat("cleanEx()\nnameEx(\"", nm, "\")\n", sep = "", file = out)

        cat("### * ", nm, "\n\n", sep = "", file = out)
        cat("flush(stderr()); flush(stdout())\n\n", file = out)
        dont_test <- FALSE
        if(addTiming)
            cat("base::assign(\".ptime\", proc.time(), pos = \"CheckExEnv\")\n",
                file = out)
        for (line in lines) {
            if(any(grepl("^[[:space:]]*## No test:", line, perl = TRUE, useBytes = TRUE)))
                dont_test <- TRUE
            if(!dont_test) cat(line, "\n", sep = "", file = out)
            if(any(grepl("^[[:space:]]*## End\\(No test\\)",
                         line, perl = TRUE, useBytes = TRUE)))
                dont_test <- FALSE
        }

        if(addTiming) {
            cat("base::assign(\".dptime\", (proc.time() - get(\".ptime\", pos = \"CheckExEnv\")), pos = \"CheckExEnv\")\n", file = out)
            cat("base::cat(\"", nm, "\", base::get(\".format_ptime\", pos = 'CheckExEnv')(get(\".dptime\", pos = \"CheckExEnv\")), \"\\n\", file=base::get(\".ExTimings\", pos = 'CheckExEnv'), append=TRUE, sep=\"\\t\")\n", sep = "", file = out)
        }
        if(have_par)
            cat("graphics::par(get(\"par.postscript\", pos = 'CheckExEnv'))\n", file = out)
        if(have_contrasts)
            cat("base::options(contrasts = c(unordered = \"contr.treatment\",",
                "ordered = \"contr.poly\"))\n", sep="", file = out)
    }

    cat(readLines(file.path(R.home("share"), "R", "examples-footer.R")),
        sep = "\n", file = out)
}

## compares 2 files
Rdiff <- function(from, to, useDiff = FALSE, forEx = FALSE,
                  nullPointers=TRUE, Log = FALSE)
{
    clean <- function(txt)
    {
        if(!length(txt)) return(txt)
        ## remove R header
        if(length(top <- grep("^(R version|R : Copyright|R Under development)",
                              txt, perl = TRUE, useBytes = TRUE)) &&
           length(bot <- grep("quit R.$", txt, perl = TRUE, useBytes = TRUE)))
            txt <- txt[-(top[1L]:bot[1L])]
        ## for massageExamples()
        ll <- grep("</HEADER>", txt, fixed = TRUE, useBytes = TRUE)
        if(length(ll)) txt <- txt[-seq_len(max(ll))]
        ll <- grep("<FOOTER>", txt, fixed = TRUE, useBytes = TRUE)
        if(length(ll)) txt <- txt[seq_len(max(ll) - 1L)]
        ## remove BATCH footer
        nl <- length(txt)
        if(nl > 3L && grepl("^> proc.time\\(\\)", txt[nl-2L])) txt <- txt[1:(nl-3L)]
        if (nullPointers)
        ## remove pointer addresses from listings
            txt <- gsub("<(environment|bytecode|pointer|promise): [x[:xdigit:]]+>", "<\\1: 0>", txt)
        ## regularize fancy quotes.  First UTF-8 ones:
        txt <- gsub("(\xe2\x80\x98|\xe2\x80\x99)", "'", txt,
                      perl = TRUE, useBytes = TRUE)
        txt <- gsub("(\xe2\x80\x9c|\xe2\x80\x9d)", '"', txt,
                      perl = TRUE, useBytes = TRUE)
        if(.Platform$OS.type == "windows") {
            ## not entirely safe ...
            txt <- gsub("(\x91|\x92)", "'", txt, perl = TRUE, useBytes = TRUE)
            txt <- gsub("(\x93|\x94)", '"', txt, perl = TRUE, useBytes = TRUE)
            txt <- txt[!grepl('options(pager = "console")', txt,
                              fixed = TRUE, useBytes = TRUE)]
        }
        pat <- '(^Time |^Loading required package|^Package [A-Za-z][A-Za-z0-9]+ loaded|^<(environment|promise|pointer|bytecode):|^/CreationDate |^/ModDate |^/Producer )'
        txt[!grepl(pat, txt, perl = TRUE, useBytes = TRUE)]
    }
    clean2 <- function(txt)
    {
        eoh <- grep("^> options\\(warn = 1\\)$", txt)
        if(length(eoh)) txt[-(1L:eoh[1L])] else txt
    }

    left <- clean(readLines(from))
    right <- clean(readLines(to))
    if (forEx) {
        left <- clean2(left)
        ## remove lines from R CMD check --timings
        left <- grep("[.](format_|)ptime", left, value = TRUE,
                     invert = TRUE, useBytes = TRUE)
        right <- clean2(right)
    }
    if (!useDiff && (length(left) == length(right))) {
        ## The idea is to emulate diff -b, as documented by POSIX:
        ## http://pubs.opengroup.org/onlinepubs/9699919799/utilities/diff.html
        bleft <- gsub("[[:space:]]*$", "", left)
        bright <- gsub("[[:space:]]*$", "", right)
        bleft <- gsub("[[:space:]]+", " ", bleft)
        bright <- gsub("[[:space:]]+", " ", bright)
        if(all(bleft == bright))
            return(if(Log) list(status = 0L, out = character()) else 0L)
        cat("\n")
        diff <- bleft != bright
        ## FIXME do run lengths here
        for(i in which(diff))
            cat(i,"c", i, "\n< ", left[i], "\n", "---\n> ", right[i], "\n",
                sep = "")
        if (Log) {
            i <- which(diff)
            out <- paste0(i,"c", i, "\n< ", left[i], "\n", "---\n> ", right[i])
            list(status = 1L, out = out)
        } else 1L
    } else {
        ## FIXME: use C code, or something like merge?
        ## The files can be very big.
        out <- character()
        if(!useDiff) {
            cat("\nfiles differ in number of lines:\n")
            out <- "files differ in number of lines"
        }
        a <- tempfile("Rdiffa")
        writeLines(left, a)
        b <- tempfile("Rdiffb")
        writeLines(right, b)
        if (Log) {
            tf <- tempfile()
            status <- system2("diff", c("-bw", shQuote(a), shQuote(b)),
                              stdout = tf, stderr = tf)
            list(status = status, out = c(out, readLines(tf)))
        } else system(paste("diff -bw", shQuote(a), shQuote(b)))
    }
}

testInstalledPackages <-
    function(outDir = ".", errorsAreFatal = TRUE,
             scope = c("both", "base", "recommended"),
             types = c("examples", "tests", "vignettes"),
             srcdir = NULL, Ropts = "")
{
    ow <- options(warn = 1)
    on.exit(ow)
    scope <- match.arg(scope)
    status <- 0L
    pkgs <- character()
    known_packages <- .get_standard_package_names()
    if (scope %in% c("both", "base"))
        pkgs <- known_packages$base
    if (scope %in% c("both", "recommended"))
        pkgs <- c(pkgs, known_packages$recommended)
    mc.cores <- as.integer(Sys.getenv("TEST_MC_CORES", 1L))
    if (.Platform$OS.type != "windows" &&
        !is.na(mc.cores) && mc.cores > 1L) {
        do_one <- function(pkg) {
            if(is.null(srcdir) && pkg %in% known_packages$base)
                srcdir <- R.home("tests/Examples")
            testInstalledPackage(pkg, .Library, outDir, types, srcdir, Ropts)
        }
        res <- parallel::mclapply(pkgs, do_one, mc.cores = mc.cores,
                                  mc.preschedule = FALSE)
        res <- unlist(res) != 0L
        if (any(res)) {
            for(i in which(res))
                warning(gettextf("testing '%s' failed", pkgs[i]),
                        domain = NA, call. = FALSE, immediate. = TRUE)
            if (errorsAreFatal)
                stop(gettextf("%d of the package tests failed", sum(res)),
                     domain = NA, call. = FALSE)
        }
    } else {
        for (pkg in pkgs) {
            if(is.null(srcdir) && pkg %in% known_packages$base)
                srcdir <- R.home("tests/Examples")
            res <- testInstalledPackage(pkg, .Library, outDir, types, srcdir, Ropts)
            if (res) {
                status <- 1L
                msg <- gettextf("testing '%s' failed", pkg)
                if (errorsAreFatal) stop(msg, domain = NA, call. = FALSE)
                else warning(msg, domain = NA, call. = FALSE, immediate. = TRUE)
            }
        }
    }
    invisible(status)
}

testInstalledPackage <-
    function(pkg, lib.loc = NULL, outDir = ".",
             types = c("examples", "tests", "vignettes"),
             srcdir = NULL, Ropts = "")
{
    types <- pmatch(types, c("examples", "tests", "vignettes"))
    pkgdir <- find.package(pkg, lib.loc)
    exdir <- file.path(pkgdir, "R-ex")
    owd <- setwd(outDir)
    on.exit(setwd(owd))
    strict <- as.logical(Sys.getenv("R_STRICT_PACKAGE_CHECK", "FALSE"))

    if (1 %in% types) {
        message(gettextf("Testing examples for package %s", sQuote(pkg)),
                domain = NA)
        Rfile <- .createExdotR(pkg, pkgdir, silent = TRUE)
        if (length(Rfile)) {
            outfile <- paste0(pkg, "-Ex.Rout")
            failfile <- paste(outfile, "fail", sep = "." )
            savefile <- paste(outfile, "prev", sep = "." )
            if (file.exists(outfile)) file.rename(outfile, savefile)
            unlink(failfile)
            ## Create as .fail in case this R session gets killed
            cmd <- paste(shQuote(file.path(R.home("bin"), "R")),
                         "CMD BATCH --vanilla --no-timing", Ropts,
                         shQuote(Rfile), shQuote(failfile))
            if (.Platform$OS.type == "windows") Sys.setenv(R_LIBS="")
            else cmd <- paste("R_LIBS=", cmd)
            res <- system(cmd)
            if (res) return(invisible(1L)) else file.rename(failfile, outfile)

            savefile <- paste(outfile, "save", sep = "." )
            if (!is.null(srcdir)) savefile <- file.path(srcdir, savefile)
            else {
                tfile <- file.path(pkgdir, "tests", "Examples" , savefile)
                if(!file.exists(savefile) && file.exists(tfile))
                    savefile <- tfile
            }
            if (file.exists(savefile)) {
               if (file.exists(savefile)) {
                   message(gettextf("  comparing %s to %s ...",
                                    sQuote(outfile), sQuote(basename(savefile))),
                           appendLF = FALSE, domain = NA)
                    res <- Rdiff(outfile, savefile)
                    if (!res) message(" OK")
                    else if(strict)
                        stop("  ", "results differ from reference results")
                }
            } else {
                prevfile <- paste(outfile, "prev", sep = "." )
                if (file.exists(prevfile)) {
                    message(gettextf("  comparing %s to %s ...",
                            sQuote(outfile), sQuote(basename(prevfile))),
                            appendLF = FALSE, domain = NA)
                    res <- Rdiff(outfile, prevfile)
                    if (!res) message(" OK")
                }
            }
        } else
            warning(gettextf("no examples found for package %s", sQuote(pkg)),
                    call. = FALSE, domain = NA)
    }

    ## FIXME merge with code in .runPackageTests
    if (2 %in% types && file_test("-d", d <- file.path(pkgdir, "tests"))) {
        this <- paste(pkg, "tests", sep = "-")
        unlink(this, recursive = TRUE)
        dir.create(this)
        ## system(paste("cp -pR", file.path(d, "*"), this))
        file.copy(Sys.glob(file.path(d, "*")), this, recursive = TRUE)
        setwd(this)
        message(gettextf("Running specific tests for package %s",
                         sQuote(pkg)), domain = NA)
        Rfiles <- dir(".", pattern="\\.R$")
        for(f in Rfiles) {
            message(gettextf("  Running %s", sQuote(f)), domain = NA)
            outfile <- paste0(f, "out")
            cmd <- paste(shQuote(file.path(R.home("bin"), "R")),
                         "CMD BATCH --vanilla --no-timing", Ropts,
                         shQuote(f), shQuote(outfile))
            cmd <- if (.Platform$OS.type == "windows") paste(cmd, "LANGUAGE=C")
            else paste("LANGUAGE=C", cmd)
           res <- system(cmd)
            if (res) {
                file.rename(outfile, paste(outfile, "fail", sep = "."))
                return(invisible(1L))
            }
            savefile <- paste(outfile, "save", sep = "." )
            if (file.exists(savefile)) {
                message(gettextf("  comparing %s to %s ...",
                                 sQuote(outfile), sQuote(savefile)),
                        appendLF = FALSE, domain = NA)
                res <- Rdiff(outfile, savefile)
                if (!res) message(" OK")
            }
        }
        setwd(owd)
    }

    if (3 %in% types && file_test("-d", d <- file.path(pkgdir, "doc"))) {
        message(gettextf("Running vignettes for package %s", sQuote(pkg)),
                domain = NA)
        checkVignettes(pkg, lib.loc, latex = FALSE, weave =TRUE)
    }

    invisible(0L)
}

## run all the tests in a directory: for use by R CMD check.
## trackObjs has .Rin files

## used by R CMD check
.runPackageTestsR <- function(...)
{
    cat("\n");
    status <- .runPackageTests(...)
    q("no", status = status)
}

.runPackageTests <- function(use_gct = FALSE, use_valgrind = FALSE, Log = NULL)
{
    if (!is.null(Log)) Log <- file(Log, "wt")
    WINDOWS <- .Platform$OS.type == "windows"
    td0 <- as.numeric(Sys.getenv("_R_CHECK_TIMINGS_"))
    if (is.na(td0)) td0 <- Inf
    print_time <- function(t1, t2, Log)
    {
        td <- t2 - t1
        if(td[3L] < td0) td2 <- ""
        else {
            td2 <- if (td[3L] > 600) {
                td <- td/60
                if(WINDOWS) sprintf(" [%dm]", round(td[3L]))
                else sprintf(" [%dm/%dm]", round(sum(td[-3L])), round(td[3L]))
            } else {
                if(WINDOWS) sprintf(" [%ds]", round(td[3L]))
                else sprintf(" [%ds/%ds]", round(sum(td[-3L])), round(td[3L]))
            }
        }
        message(td2, domain = NA)
        if (!is.null(Log)) cat(td2, "\n", sep = "",  file = Log)
    }
    runone <- function(f)
    {
        message(gettextf("  Running %s", sQuote(f)),
                appendLF = FALSE, domain = NA)
        if(!is.null(Log))
            cat("  Running ", sQuote(f), sep = "", file = Log)
        outfile <- paste0(f, "out")
        cmd <- paste(shQuote(file.path(R.home("bin"), "R")),
                     "CMD BATCH --vanilla",
                     if(use_valgrind) "--debugger=valgrind",
                     shQuote(f), shQuote(outfile))
        if (WINDOWS) {
            Sys.setenv(LANGUAGE="C")
            Sys.setenv(R_TESTS="startup.Rs")
        } else
            cmd <- paste("LANGUAGE=C", "R_TESTS=startup.Rs", cmd)
        t1 <- proc.time()
        res <- system(cmd)
        t2 <- proc.time()
        print_time(t1, t2, Log)
        if (res) {
            file.rename(outfile, paste(outfile, "fail", sep = "."))
            return(1L)
        }
        savefile <- paste(outfile, "save", sep = "." )
        if (file.exists(savefile)) {
            message(gettextf("  Comparing %s to %s ...",
                             sQuote(outfile), sQuote(savefile)),
                    appendLF = FALSE, domain = NA)
            if(!is.null(Log))
                cat("  Comparing ", sQuote(outfile), " to ",
                    sQuote(savefile), " ...", sep = "", file = Log)
            if(!is.null(Log)) {
                ans <- Rdiff(outfile, savefile, TRUE, Log = TRUE)
                writeLines(ans$out)
                writeLines(ans$out, Log)
                res <- ans$status
            } else res <- Rdiff(outfile, savefile, TRUE)
            if (!res) {
                message(" OK")
                if(!is.null(Log)) cat(" OK\n", file = Log)
            }
        }
        0L
    }

    file.copy(file.path(R.home("share"), "R", "tests-startup.R"), "startup.Rs")
    if (use_gct) cat("gctorture(TRUE)" , file = "startup.Rs", append = TRUE)
    nfail <- 0L ## allow for later running all tests even if some fail.
    Rinfiles <- dir(".", pattern="\\.Rin$")
    for(f in Rinfiles) {
        Rfile <- sub("\\.Rin$", ".R", f)
        message("  Creating ", sQuote(Rfile), domain = NA)
        if (!is.null(Log))
            cat("  Creating ", sQuote(Rfile), "\n", sep = "", file = Log)
        cmd <- paste(shQuote(file.path(R.home("bin"), "R")),
                     "CMD BATCH --no-timing --vanilla --slave", f)
        if (system(cmd)) {
            warning("creation of ", sQuote(Rfile), " failed", domain = NA)
            if (!is.null(Log))
                cat("Warning: creation of ", sQuote(Rfile), " failed\n",
                    sep = "", file = Log)
        } else if (file.exists(Rfile)) nfail <- nfail + runone(Rfile)
        if (nfail > 0) return(nfail)
    }

    Rfiles <- dir(".", pattern="\\.R$")
    for(f in Rfiles) {
        nfail <- nfail + runone(f)
        if (nfail > 0) return(nfail)
    }
    if (!is.null(Log)) close(Log)
    return(nfail)
}

.createExdotR <-
    function(pkg, pkgdir, silent = FALSE, use_gct = FALSE, addTiming = FALSE)
{
    Rfile <- paste0(pkg, "-Ex.R")
    ## might be zipped:
    exdir <- file.path(pkgdir, "R-ex")

    db <- Rd_db(basename(pkgdir), lib.loc = dirname(pkgdir))
    if (!length(db)) {
        message("no parsed files found")
        return(invisible(NULL))
    }
    if (!silent) message("  Extracting from parsed Rd's ",
                         appendLF = FALSE, domain = NA)
    files <- names(db)
    if (pkg == "grDevices")
        files <- files[!grepl("^(unix|windows)/", files)]
    filedir <- tempfile()
    dir.create(filedir)
    on.exit(unlink(filedir, recursive = TRUE))
    cnt <- 0L
    for(f in files) {
        nm <- sub("\\.[Rr]d$", "", basename(f))
        Rd2ex(db[[f]],
              file.path(filedir, paste(nm, "R", sep = ".")),
              defines = NULL)
        cnt <- cnt + 1L
        if(!silent && cnt %% 10L == 0L)
            message(".", appendLF = FALSE, domain = NA)
    }
    if (!silent) message()
    nof <- length(Sys.glob(file.path(filedir, "*.R")))
    if(!nof) return(invisible(NULL))

    massageExamples(pkg, filedir, Rfile, use_gct, addTiming)
    invisible(Rfile)
}

testInstalledBasic <- function(scope = c("basic", "devel", "both"))
{
    scope <- match.arg(scope)

    ## We need to force C collation: might not work
    Sys.setlocale("LC_COLLATE", "C")
    tests1 <- c("eval-etc", "simple-true", "arith-true", "lm-tests",
                "ok-errors", "method-dispatch", "array-subset",
                "any-all", "d-p-q-r-tests")
    tests2 <- c("complex", "print-tests", "lapack", "datasets", "iec60559")
    tests3 <- c("reg-tests-1a", "reg-tests-1b", "reg-tests-1c", "reg-tests-2",
                "reg-examples1", "reg-examples2", "reg-packages",
                "reg-IO", "reg-IO2", "reg-S4", "reg-plot", "reg-BLAS")

    runone <- function(f, diffOK = FALSE, inC = TRUE)
    {
        f <- paste(f, "R", sep = ".")
        if (!file.exists(f)) {
            if (!file.exists(fin <- paste0(f, "in")))
                stop("file ", sQuote(f), " not found", domain = NA)
            message("creating ", sQuote(f), domain = NA)
            ## FIXME: this creates an extra trailing space compared to
            ## the .Rin.R rule
            cmd <- paste(shQuote(file.path(R.home("bin"), "R")),
                         "--vanilla --slave -f", fin)
            if (system(cmd))
                stop("creation of ", sQuote(f), " failed", domain = NA)
            on.exit(unlink(f))
        }
        message("  running code in ", sQuote(f), domain = NA)
        outfile <- paste0(f, "out")
        cmd <- paste(shQuote(file.path(R.home("bin"), "R")),
                     "CMD BATCH --vanilla --no-timing",
                     shQuote(f), shQuote(outfile))
        extra <- paste("LANGUAGE=en", "LC_COLLATE=C",
                       "R_DEFAULT_PACKAGES=", "SRCDIR=.")
        if (inC) extra <- paste(extra,  "LC_ALL=C")
        if (.Platform$OS.type == "windows") {
            Sys.setenv(LANGUAGE="C")
            Sys.setenv(R_DEFAULT_PACKAGES="")
            Sys.setenv(LC_COLLATE="C")
            Sys.setenv(SRCDIR=".")
            ## ignore inC and hope
        } else cmd <- paste(extra, cmd)
        res <- system(cmd)
        if (res) {
            file.rename(outfile, paste(outfile, "fail", sep = "."))
            message("FAILED")
            return(1L)
        }
        savefile <- paste(outfile, "save", sep = "." )
        if (file.exists(savefile)) {
            message(gettextf("  comparing %s to %s ...",
                             sQuote(outfile), sQuote(savefile)),
                    appendLF = FALSE, domain = NA)
            res <- Rdiff(outfile, savefile, TRUE)
            if (!res) message(" OK")
            else if (!diffOK) return(1L)
        }
        0L
    }
    owd <- setwd(file.path(R.home(), "tests"))
    on.exit(setwd(owd))

    if (scope %in% c("basic", "both")) {
        message("running strict specific tests", domain = NA)
        for (f in tests1) if (runone(f)) return(1L)
        message("running sloppy specific tests", domain = NA)
        for (f in tests2) runone(f, TRUE)
        message("running regression tests", domain = NA)
        for (f in tests3) {
            if (runone(f)) return(invisible(1L))
            if (f == "reg-plot") {
                message("  comparing 'reg-plot.pdf' to 'reg-plot.pdf.save' ...",
                        appendLF = FALSE, domain = NA)
                res <- Rdiff("reg-plot.pdf", "reg-plot.pdf.save")
                if(res != 0L) message("DIFFERED") else message("OK")
            }
        }
        runone("reg-tests-3", TRUE)
        message("running tests of plotting Latin-1", domain = NA)
        message("  expect failure or some differences if not in a Latin or UTF-8 locale", domain = NA)

        runone("reg-plot-latin1", TRUE, FALSE)
        message("  comparing 'reg-plot-latin1.pdf' to 'reg-plot-latin1.pdf.save' ...",
                appendLF = FALSE, domain = NA)
        res <- Rdiff("reg-plot-latin1.pdf", "reg-plot-latin1.pdf.save")
        if(res != 0L) message("DIFFERED") else message("OK")
    }

    if (scope %in% c("devel", "both")) {
        message("running tests of consistency of as/is.*", domain = NA)
        runone("isas-tests")
        message("running tests of random deviate generation -- fails occasionally")
        runone("p-r-random-tests", TRUE)
        message("running tests of primitives", domain = NA)
        if (runone("primitives")) return(invisible(1L))
        message("running regexp regression tests", domain = NA)
        if (runone("utf8-regex", inC = FALSE)) return(invisible(1L))
        message("running tests to possibly trigger segfaults", domain = NA)
        if (runone("no-segfault")) return(invisible(1L))
    }

    invisible(0L)
}

detachPackages <- function(pkgs, verbose = TRUE)
{
    pkgs <- pkgs[pkgs %in% search()]
    if(!length(pkgs)) return()
    if(verbose){
        msg <- paste("detaching", paste(sQuote(pkgs), collapse = ", "))
        cat("", strwrap(msg, exdent = 2L), "", sep = "\n")
    }

    ## Normally 'pkgs' will be in reverse order of attachment (latest first)
    ## but not always (e.g. BioC package CMA attaches at the end).

    ## The items need not all be packages
    ## and non-packages can be on the list multiple times.
    isPkg <- grepl("^package:", pkgs)
    for(item in pkgs[!isPkg]) {
        pos <- match(item, search())
        if(!is.na(pos)) .detach(pos)
    }

    pkgs <- pkgs[isPkg]
    if(!length(pkgs)) return()

    deps <- lapply(pkgs, function(x) if(exists(".Depends", x, inherits = FALSE)) get(".Depends", x) else character())
    names(deps) <- pkgs

    unload <- nzchar(Sys.getenv("_R_CHECK_UNLOAD_NAMESPACES_"))
    ## unloading 'grid' kills all devices
    ## tcltk is unhappy to have its DLL unloaded repeatedly
    exclusions <- c("grid", "tcltk")
    exclusions <- paste("package", exclusions, sep = ":")
    while(length(deps)) {
        unl <- unlist(deps)
        for(i in seq_along(deps)) {
            this <- names(deps)[i]
            if(sub("^package:", "", this) %in% unl) next else break
        }
        ## hopefully force = TRUE is never needed, but it does ensure
        ## that progress gets made
        try(detach(this, character.only = TRUE,
                   unload = unload && !(this %in% exclusions),
                   force = TRUE))
        deps <- deps[-i]
    }
}

## Usage: Rscript --vanilla --default-packages=NULL args
.Rdiff <- function()
{
    options(showErrorCalls=FALSE)

    Usage <- function() {
        cat("Usage: R CMD Rdiff FROM-FILE TO-FILE EXITSTATUS",
            "",
            "Diff R output files FROM-FILE and TO-FILE discarding the R startup message,",
            "where FROM-FILE equal to '-' means stdin.",
            "",
            "Options:",
            "  -h, --help     print this help message and exit",
            "  -v, --version  print version info and exit",
            "",
            "Report bugs at bugs.r-project.org .",
            sep = "\n")
    }

    do_exit <- function(status = 0L)
        q("no", status = status, runLast = FALSE)

    args <- commandArgs(TRUE)
    if (!length(args)) {
        Usage()
        do_exit(1L)
    }
    args <- paste(args, collapse=" ")
    args <- strsplit(args,'nextArg', fixed = TRUE)[[1L]][-1L]
    if (length(args) == 1L) {
        if(args[1L] %in% c("-h", "--help")) { Usage(); do_exit() }
        if(args[1L] %in% c("-v", "--version")) {
            cat("R output diff: ",
                R.version[["major"]], ".",  R.version[["minor"]],
                " (r", R.version[["svn rev"]], ")\n", sep = "")
            cat("",
                "Copyright (C) 2000-2013 The R Core Team.",
                "This is free software; see the GNU General Public License version 2",
                "or later for copying conditions.  There is NO warranty.",
                sep = "\n")
            do_exit()
        }
        Usage()
        do_exit(1L)
    }


    if (length(args) < 2L) {
        Usage()
        do_exit(1L)
    }
    exitstatus <- as.integer(args[3L])
    if(is.na(exitstatus)) exitstatus <- 0L

    left <- args[1L]
    if(left == "-") left <- "stdin"
    status <- Rdiff(left, args[2L], useDiff = TRUE)
    if(status) status <- exitstatus
    do_exit(status)
}
toHTML <- function(x, ...) UseMethod("toHTML")

#
#  Copyright (C) 1995-2013 The R Core Team

HTMLheader <-
function(title="R", logo=TRUE,
         up=NULL,
         top=file.path(Rhome, "doc/html/index.html"),
         Rhome="",
         css = file.path(Rhome, "doc/html/R.css"),
         headerTitle = paste("R:", title),
         outputEncoding = "UTF-8")
{
    result <- c('<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">',
	paste0('<html><head><title>', headerTitle, '</title>'),
	paste0('<meta http-equiv="Content-Type" content="text/html; charset=',
	       mime_canonical_encoding(outputEncoding), '">'),
	paste0('<link rel="stylesheet" type="text/css" href="', css, '">'),
	'</head><body>',
	paste('<h1>', title))
    if (logo)
    	result <- c(result,
                    paste0('<img class="toplogo" src="',
                           file.path(Rhome, 'doc/html/logo.jpg'), '" alt="[R logo]">'))
    result <- c(result, '</h1>', '<hr>')
    if (!is.null(up) || !is.null(top)) {
    	result <- c(result, '<div align="center">')
    	if (!is.null(up))
    	    result <- c(result,
    	        paste0('<a href="', up, '"><img src="',
                       file.path(Rhome, 'doc/html/left.jpg'),
                       '" alt="[Up]" width="30" height="30" border="0"></a>'))
    	if (!is.null(top))
    	    result <- c(result,
    	    	paste0('<a href="', top, '"><img src="',
    	    	      file.path(Rhome, 'doc/html/up.jpg'),
    	    	      '" alt="[Top]" width="30" height="30" border="0"></a>'))
    	result <- c(result, '</div>')
    }
    result
}

toHTML.packageIQR <-
function(x, ...)
{
    db <- x$results

    # Re-encode as utf-8
    x$title <- iconv(x$title, to="UTF-8")
    x$footer <- iconv(x$footer, to="UTF-8")
    db <- iconv(db, to="UTF-8")

    ## Split according to Package.
    out <- if(nrow(db) == 0L)
         NULL
    else
        lapply(split(1:nrow(db), db[, "Package"]),
               function(ind) db[ind, c("Item", "Title"), drop = FALSE])

    result <- HTMLheader(...)

    for(pkg in names(out)) {
        result <- c(result,
		    paste0('<h2>', htmlify(x$title), ' in package &lsquo;',
			   htmlify(pkg), '&rsquo;</h2>'),
		    '<table cols="2" width="100%">',
		    paste0('<tr>\n',
			   ' <td align="left" valign="top" width="10%">\n',
			   htmlify(out[[pkg]][, "Item"]),
			   '\n </td>\n <td align="left" valign="top" width="90%">\n',
			   htmlify(out[[pkg]][, "Title"]),
			   '\n </td>\n</tr>\n'),
		    '</table>')
    }
    if(!is.null(x$footer))
    	result <- c(result, '<p>',
    	                    htmlify(x$footer),
    	                    '</p>')
    result <- c(result, '</body></html>')
    result
}

toHTML.news_db <-
function(x, ...)
{
    ## local version
    htmlify2 <- function(x) {
        x <- psub("<([[:alnum:]._]+)>", "@VAR@\\1@EVAR@", x)
        x <- fsub("&", "&amp;", x)
        x <- fsub("---", "&mdash;", x)
        ## usually a flag like --timing
        ## x <- fsub("--", "&ndash;", x)
        x <- fsub("``", "&ldquo;", x)
        x <- fsub("''", "&rdquo;", x)
        x <- psub("`([^']+)'", "&lsquo;\\1&rsquo;", x)
        x <- fsub("`", "'", x)
        x <- fsub("<", "&lt;", x)
        x <- fsub(">", "&gt;", x)
        x <- fsub("@VAR@", "<var>", x)
        x <- fsub("@EVAR@", "</var>", x)
        x
    }

    ## For now, only do something if the NEWS file could be read without
    ## problems, see utils:::print.news_db():
    if(is.null(bad <- attr(x, "bad"))
       || (length(bad) != NROW(x))
       || any(bad))
        return(character())

    print_items <- function(x)
        c("<ul>", sprintf("<li>%s</li>", htmlify2(x)), "</ul>")

    x$Text <- iconv(x$Text, to = "UTF-8")

    vchunks <- split(x, x$Version)
    vchunks <-
        vchunks[order(as.numeric_version(sub(" *patched", ".1",
                                             names(vchunks))),
                      decreasing = TRUE)]
    vheaders <- sprintf("<h2>Changes in version %s</h2>",
                        names(vchunks))
    c(HTMLheader(...),
      unlist(lapply(seq_along(vchunks),
                    function(i) {
                        vchunk <- vchunks[[i]]
                        if(all(!is.na(category <- vchunk$Category)
                               & nzchar(category))) {
                            ## need to preserve order of headings.
                            cchunks <- split(vchunk,
                                             factor(category, levels=unique(category)))
                            c(vheaders[i],
                              Map(function(h, t)
                                  c(h, print_items(t$Text)),
                                  sprintf("<h3>%s</h3>", names(cchunks)),
                                  cchunks))
                        } else {
                            c(vheaders[i],
                              print_items(vchunk$Text))
                        }
                    })
             ),
      "</body></html>")
}

# To support static linking, URLs should be relative.
# Argument "depth" below says how far down in the hierarchy
# we are starting from, e.g. /library/stats/html/mean.html
# is depth 3

makeVignetteTable <- function(vignettes, depth=2) {
    out <- c('<table width="100%">',
	      '<col width="22%">',
	      '<col width="2%">',
	      '<col width="50%">',
	      '<col width="8%">',
	      '<col width="8%">',
	      '<col width="8%">')
    for (i in seq_len(nrow(vignettes))) {
	Outfile <- vignettes[i, "PDF"]
	topic <- file_path_sans_ext(Outfile)
	Title <- vignettes[i, "Title"]
	File  <- vignettes[i, "File"]
	R     <- vignettes[i, "R"]
	pkg   <- vignettes[i, "Package"]
        root <- c(rep("../", depth), "library/", pkg, "/doc/")
	link  <- c('<a href="', root,
		  if (nchar(Outfile)) Outfile else File, '">',
		  pkg, "::", topic, '</a>')
	line <- c('<tr><td align="right" valign="top">', link,
		    '</td>\n<td></td><td valign="top">', Title,
		    '</td>\n<td valign="top">',
		    if (nchar(Outfile))
			c('<a href="', root, Outfile,'">', vignette_type(Outfile), '</a>'),
		    '</td>\n<td valign="top">',
		    '<a href="', root, File,'">source</a>',
		    '</td>\n<td valign="top" nowrap>',
		    if (nchar(R))
		    	c('<a href="', root, R,'">R code</a>'),
		    '</td></tr>')
	out <- c(out, paste(line, collapse=''))
     }
     c(out, '</table>')
}

makeDemoTable <- function(demos, depth=2) {
    out <- c('<table width="100%">',
	      '<col width="22%">',
	      '<col width="2%">',
	      '<col width="54%">',
	      '<col width="20%">')
    for (i in seq_len(nrow(demos))) {
	topic <- demos[i, "topic"]
	pkg <- demos[i, "Package"]
        root <- c(rep("../", depth), "library/", pkg, "/")
	Title <- demos[i, "title"]
	path <- file.path(demos[i, "LibPath"], "demo")
	files <- basename(list_files_with_type(path, "demo", full.names=FALSE))
	file <- files[topic == file_path_sans_ext(files)]
	if (length(file) == 1) {
	    link <- c('<a href="', root, 'demo/', file, '">',
			  pkg, "::", topic, '</a>')
	    runlink <- c(' <a href="', root, 'Demo/', topic,
	                 '">(Run demo in console)</a>')
	} else {
	    link <- c(pkg, "::", topic)
	    runlink <- ""
	}
	line <- c('<tr><td align="right" valign="top">', link,
		    '</td>\n<td></td><td valign="top">', Title,
		    '</td>\n<td valign="top" nowrap>', runlink,
		    '</td></tr>')
	out <- c(out, paste(line, collapse=''))
     }
     c(out, '</table>')
}

makeHelpTable <- function(help, depth=2) {
    out <- c('<table width="100%">',
	      '<col width="22%">',
	      '<col width="2%">',
	      '<col width="74%">')
    pkg <- help[,"Package"]
    root <- paste0(paste(rep.int("../", depth), collapse=""),
                   "library/", pkg, "/html/")
    topic <- help[, "topic"]
    Title <- help[, "title"]
    name <- help[, "name"]
    links <- paste0('<a href="', root, topic, '.html">',
		    ifelse(nchar(pkg), paste0(pkg, "::"), ""),
		    topic, '</a>')
    lines <- paste0('<tr><td align="right" valign="top">', links,
		    '</td>\n<td></td><td valign="top">', Title,
		    '</td></tr>')
    c(out, lines, '</table>')
}
#  File src/library/tools/R/tools-defunct.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/

## Defunct 2009-08-19
## Removed for 3.0.0
## Rd_parse <-function(file, text = NULL) .Defunct("parse_Rd")

## Deprecated for 3.0.2
## Defunct for 3.1.0 (and there is no such 'file')
readNEWS <- function(file = file.path(R.home(), "NEWS"),
                     trace = FALSE, chop = c("first", "1", "par1", "keepAll"))
    .Defunct()

checkNEWS <- function(file = file.path(R.home(), "NEWS"))
    .Defunct()
#  File src/library/tools/R/tools-deprecated.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2012 The R 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 of the License, 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/

## <entry>
## Deprecated in 2.1.0.
## </entry>
#  File src/library/tools/R/translations.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/

#### R based engine for managing translations

## This only works in a UTF-8 locale: specifically substr needs to count
## UTF-8 chars
en_quote <- function(potfile, outfile)
{
    tfile <- tempfile()
    cmd <- paste("msginit -i", potfile, "--no-translator -l en -o", tfile)
    if(system(cmd, ignore.stderr = TRUE) != 0L)
        stop("running msginit failed", domain = NA)
    tfile2 <- tempfile()
    cmd <- paste("msgconv -t UTF-8 -o", tfile2, tfile)
    if(system(cmd) != 0L) stop("running msgconv failed", domain = NA)
    lines <- readLines(tfile2) # will be in UTF-8
    starts <- grep("^msgstr", lines)
    current <- 1L; out <- character()
    for (s in starts) {
        if (current < s)
            out <- c(out, lines[seq.int(current, s-1L, 1L)])
        start <- sub('([^"]*)"(.*)"$', "\\1", lines[s])
        this <- sub('([^"]*)"(.*)"$', "\\2", lines[s])
        current <- s+1L
        while(grepl('^"', lines[current])) {
            this <- c(this, sub('^"(.*)"$', "\\1", lines[current]))
            current <- current + 1L
        }
        nc <- nchar(this); n <- length(nc)
        this <- paste0(this, collapse="")
        ## This is the fixup: need to avoid apostrophes, which follow alnum
        this <- gsub("^'([^`']*)'",'‘\\1’', this)
        this <- gsub("([^[:alpha:]]|\\\\\n)'([^`']*)'",'\\1‘\\2’', this)
        out <- if (n > 1L) {
            ## now split where it was before
            this1 <- character()
            sc <- c(0, cumsum(nc))
            for(i in seq_along(nc)) {
                if(!nc[i]) this1 <- c(this1, "")
                else {
                    this1 <- c(this1, substr(this, sc[i]+1L, sc[i+1]))
                }
            }
            c(out,
              paste0(start, '"', this1[1L] , '"'),
              paste0('"', this1[-1L] , '"'))
        } else
            c(out, paste0(start, '"', this , '"'))
    }
    if(current <= length(lines))
        out <- c(out, lines[seq.int(current, length(lines), 1L)])
    ## in case this is done on Windows, force LF line endings
    con <- file(outfile, "wb")
    writeLines(out, con, useBytes = TRUE)
    close(con)
}

update_pkg_po <- function(pkgdir, pkg = NULL, version = NULL, copyright, bugs)
{
    same <- function(a, b)
    {
        tmpa <- readLines(a); tmpb <- readLines(b)
        tmpa <- grep('^"POT-Creation-Date:', tmpa, invert = TRUE, value = TRUE)
        tmpb <- grep('^"POT-Creation-Date:', tmpb, invert = TRUE, value = TRUE)
        identical(tmpa, tmpb)
    }

    ## Follow previous version by always collating in C.
    pwd <- getwd()
    coll <- Sys.getlocale("LC_COLLATE")
    on.exit({Sys.setlocale("LC_COLLATE", coll); setwd(pwd)})
    Sys.setlocale("LC_COLLATE", "C")
    setwd(pkgdir)
    dir.create("po", FALSE)
    files <- dir("po")

    desc <- "DESCRIPTION"
    if(file.exists(desc)) {
        desc <- read.dcf(desc, fields = c("Package", "Version"))
        pkg <- name <- desc[1L]
        version <- desc[2L]
        if (missing(copyright)) copyright <- NULL
        if (missing(bugs)) bugs <- NULL
        stem <- file.path("inst", "po")
    } else { # A base package
        pkg <- basename(pkgdir)
        name <- "R"
        version <- as.character(getRversion())
        copyright <- "The R Core Team"
        bugs <- "bugs.r-project.org"
        stem <- file.path("..", "translations", "inst")
    }

    ## The interpreter is 'src' for the base package.
    is_base <- (pkg == "base")
    have_src <- paste0(pkg, ".pot") %in% files

    ## do R-pkg domain first
    ofile <- tempfile()
    xgettext2pot(".", ofile, name, version, bugs)
    potfile <- file.path("po", paste0("R-", pkg, ".pot"))
    if(file.exists(potfile) && same(potfile, ofile)) {
    } else file.copy(ofile, potfile, overwrite = TRUE)
    pofiles <- dir("po", pattern = "R-.*[.]po$", full.names = TRUE)
    pofiles <- pofiles[pofiles != "po/R-en@quot.po"]
    ## .po file might be newer than .mo
    for (f in pofiles) {
        lang <- sub("^R-(.*)[.]po$", "\\1", basename(f))
        message("  R-", lang, ":", appendLF = FALSE, domain = NA)
        ## This seems not to update the file dates.
        cmd <- paste("msgmerge --update", f, shQuote(potfile))
        if(system(cmd) != 0L) {
            warning("running msgmerge on ", sQuote(f), " failed", domain = NA)
            next
        }
        res <- checkPoFile(f, TRUE)
        if(nrow(res)) {
            print(res)
            message("not installing", domain = NA)
            next
        }
        dest <- file.path(stem, lang, "LC_MESSAGES")
        dir.create(dest, FALSE, TRUE)
        dest <- file.path(dest, sprintf("R-%s.mo", pkg))
 #       if(file_test("-ot", f, dest)) next
        cmd <- paste("msgfmt -c --statistics -o", shQuote(dest), shQuote(f))
        if(system(cmd) != 0L)
            warning(sprintf("running msgfmt on %s failed", basename(f)),
                    domain = NA, immediate. = TRUE)
    }

    ## do en@quot
    if (l10n_info()[["UTF-8"]]) {
        lang <- "en@quot"
        message("  R-", lang, ":", domain = NA)
        # f <- "po/R-en@quot.po"
        f <- tempfile()
        en_quote(potfile, f)
        dest <- file.path(stem, lang, "LC_MESSAGES")
        dir.create(dest, FALSE, TRUE)
        dest <- file.path(dest, sprintf("R-%s.mo", pkg))
        cmd <- paste("msgfmt -c --statistics -o", shQuote(dest), shQuote(f))
        if(system(cmd) != 0L)
            warning(sprintf("running msgfmt on %s failed", basename(f)),
                    domain = NA, immediate. = TRUE)
    }

    if(!(is_base || have_src)) return(invisible())

    ofile <- tempfile()
    if (!is_base) {
        dom <- pkg
        od <- setwd("src")
        exts <- "[.](c|cc|cpp|m|mm)$"
        cfiles <- dir(".", pattern = exts)
        if (file.exists("windows"))
            cfiles <- c(cfiles,
                        dir("windows", pattern = exts, full.names = TRUE))
    } else {
        dom <- "R"
        od <- setwd("../../..")
        cfiles <- grep("^#", readLines("po/POTFILES"),
                       value = TRUE, invert = TRUE)
    }
    cmd <- sprintf("xgettext --keyword=_ --keyword=N_ -o %s", shQuote(ofile))
    cmd <- c(cmd, paste("--package-name", name, sep = "="),
             paste("--package-version", version, sep = "="),
             "--add-comments=TRANSLATORS:",
             if(!is.null(copyright))
                 sprintf('--copyright-holder="%s"', copyright),
             if(!is.null(bugs))
                 sprintf('--msgid-bugs-address="%s"', bugs),
             if(is_base) "-C") # avoid messages about .y
    cmd <- paste(c(cmd, cfiles), collapse=" ")
    if(system(cmd) != 0L) stop("running xgettext failed", domain = NA)
    setwd(od)

    ## compare ofile and po/dom.pot, ignoring dates.
    potfile <- file.path("po", paste0(dom, ".pot"))
    if(!same(potfile, ofile)) file.copy(ofile, potfile, overwrite = TRUE)
    pofiles <- dir("po", pattern = "^[^R].*[.]po$", full.names = TRUE)
    pofiles <- pofiles[pofiles != "po/en@quot.po"]
    for (f in pofiles) {
        lang <- sub("[.]po", "", basename(f))
        message("  ", lang, ":", appendLF = FALSE, domain = NA)
        cmd <- paste("msgmerge --update", shQuote(f), shQuote(potfile))
        if(system(cmd) != 0L) {
            warning("running msgmerge on ",  f, " failed", domain = NA)
            next
        }
        res <- checkPoFile(f, TRUE)
        if(nrow(res)) {
            print(res)
            message("not installing", domain = NA)
            next
        }
        dest <- file.path(stem, lang, "LC_MESSAGES")
        dir.create(dest, FALSE, TRUE)
        dest <- file.path(dest, sprintf("%s.mo", dom))
#        if(file_test("-ot", f, dest)) next
        cmd <- paste("msgfmt -c --statistics -o", shQuote(dest), shQuote(f))
        if(system(cmd) != 0L)
            warning(sprintf("running msgfmt on %s failed", basename(f)),
                    domain = NA)
    }
    ## do en@quot
    if (l10n_info()[["UTF-8"]]) {
        lang <- "en@quot"
        message("  ", lang, ":", domain = NA)
        f <- tempfile()
        en_quote(potfile, f)
        dest <- file.path(stem, lang, "LC_MESSAGES")
        dir.create(dest, FALSE, TRUE)
        dest <- file.path(dest, sprintf("%s.mo", dom))
        cmd <- paste("msgfmt -c --statistics -o", shQuote(dest), shQuote(f))
        if(system(cmd) != 0L)
            warning(sprintf("running msgfmt on %s failed", basename(f)),
                    domain = NA)
    }

    invisible()
}

update_RGui_po <- function(srcdir)
{
    same <- function(a, b)
    {
        tmpa <- readLines(a); tmpb <- readLines(b)
        tmpa <- grep('^"POT-Creation-Date:', tmpa, invert = TRUE, value = TRUE)
        tmpb <- grep('^"POT-Creation-Date:', tmpb, invert = TRUE, value = TRUE)
        identical(tmpa, tmpb)
    }
    ## Follow previous version by always collating in C.
    pwd <- getwd()
    coll <- Sys.getlocale("LC_COLLATE")
    on.exit({Sys.setlocale("LC_COLLATE", coll); setwd(pwd)})
    Sys.setlocale("LC_COLLATE", "C")
    setwd(srcdir)
    cfiles <- c(file.path("src/gnuwin32",
                          c("console.c", "editor.c",  "extra.c",
                            "pager.c", "preferences.c", "rui.c", "system.c")),
                file.path("src/extra/graphapp",
                          c("clipboard.c", "dialogs.c", "gmenus.c",
                            "metafile.c", "printer.c")),
                "src/library/utils/src/windows/dataentry.c",
                "src/library/utils/src/windows/widgets.c",
                "src/library/grDevices/src/devWindows.c")
    potfile <- "src/library/base/po/RGui.pot"
    ofile <- tempfile()
    cmd <- sprintf("xgettext --keyword --keyword=G_ --keyword=GN_ -o %s", shQuote(ofile))
    cmd <- c(cmd, "--package-name=R",
             paste("--package-version", getRversion(), sep = "="),
             "--add-comments=TRANSLATORS:",
             '--copyright-holder="The R Core Team"',
             '--msgid-bugs-address="bugs.r-project.org"')
    cmd <- paste(c(cmd, cfiles), collapse=" ")
    if(system(cmd) != 0L) stop("running xgettext failed", domain = NA)
    ## compare ofile and po/RGui.pot, ignoring dates.
    if(!same(potfile, ofile)) file.copy(ofile, potfile, overwrite = TRUE)
    pofiles <- dir("src/library/base/po", pattern = "^RGui-.*[.]po$", full.names = TRUE)
    for (f in pofiles) {
        lang <- sub("^RGui-(.*)[.]po$", "\\1", basename(f))
        lang2 <- sub("[.]po", "", basename(f))
        message("  ", lang2, ":", appendLF = FALSE, domain = NA)
        cmd <- paste("msgmerge --update", f, potfile)
        if(system(cmd) != 0L) {
            warning("running msgmerge failed", domain = NA)
            next
        }
        res <- checkPoFile(f, FALSE)
        if(nrow(res)) {
            print(res)
            next
        }
        dest <- file.path("src/library/translations/inst", lang, "LC_MESSAGES")
        dir.create(dest, FALSE, TRUE)
        dest <- file.path(dest, "RGui.mo")
        if (file_test("-ot", f, dest)) next
        cmd <- paste("msgfmt -c --statistics -o", dest, f)
        if(system(cmd) != 0L)
            warning(sprintf("running msgfmt on %s failed", basename(f)),
                    domain = NA)
   }

    invisible()
}

## make package out of current translations.
make_translations_pkg <- function(srcdir, outDir = ".", append = "-1")
{
    src <- file.path(srcdir, "src/library/translations")
    dest <- file.path(tempdir(), "translations")
    dir.create(dest, FALSE)
    file.copy(file.path(src, "inst"),  dest, recursive = TRUE)
    lines <- readLines(file.path(src, "DESCRIPTION.in"))
    ver <- getRversion()
    lines <- gsub("@VERSION@", ver, lines, fixed = TRUE)
    lines[2] <- paste0(lines[2], append)
    ver <- unclass(getRversion())[[1]]
    deps <- sprintf("Depends: R (>= %s.%d.0), R (< %d.%d.0)",
                    ver[1], ver[2], ver[1], ver[2] + 1)
    lines <- c(lines, deps)
    writeLines(lines, file.path(dest, "DESCRIPTION"))
    cmd <- file.path(R.home(), "bin", "R")
    cmd <- paste(cmd, "CMD", "build", shQuote(dest))
    if(system(cmd) != 0L) stop("R CMD build failed")
    tarball <- Sys.glob(file.path(tempdir(), "translations_*.tar.gz"))
    file.rename(tarball, file.path(outDir, basename(tarball)))
    invisible()
}
#  File src/library/tools/R/utils.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/

### * File utilities.

### ** file_ext

file_ext <-
function(x)
{
    ## Return the file extensions.
    ## (Only purely alphanumeric extensions are recognized.)
    pos <- regexpr("\\.([[:alnum:]]+)$", x)
    ifelse(pos > -1L, substring(x, pos + 1L), "")
}

### ** file_path_as_absolute

file_path_as_absolute <-
function(x)
{
    ## Turn a possibly relative file path absolute, performing tilde
    ## expansion if necessary.
    if(length(x) != 1L)
        stop("'x' must be a single character string")
    if(!file.exists(epath <- path.expand(x)))
        stop(gettextf("file '%s' does not exist", x),
             domain = NA)
    normalizePath(epath, "/", TRUE)
}

### ** file_path_sans_ext

file_path_sans_ext <-
function(x, compression = FALSE)
{
    ## Return the file paths without extensions.
    ## (Only purely alphanumeric extensions are recognized.)
    if(compression)
        x <- sub("[.](gz|bz2|xz)$", "", x)
    sub("([^.]+)\\.[[:alnum:]]+$", "\\1", x)
}

### ** file_test

file_test <-
function(op, x, y)
{
    ## Provide shell-style '-f', '-d', '-x', '-nt' and '-ot' tests.
    ## Note that file.exists() only tests existence ('test -e' on some
    ## systems), and that our '-f' tests for existence and not being a
    ## directory (the GNU variant tests for being a regular file).
    ## Note: vectorized in x and y.
    switch(op,
           "-f" = !is.na(isdir <- file.info(x)$isdir) & !isdir,
           "-d" = !is.na(isdir <- file.info(x)$isdir) & isdir,
           "-nt" = (!is.na(mt.x <- file.info(x)$mtime)
                    & !is.na(mt.y <- file.info(y)$mtime)
                    & (mt.x > mt.y)),
           "-ot" = (!is.na(mt.x <- file.info(x)$mtime)
                    & !is.na(mt.y <- file.info(y)$mtime)
                    & (mt.x < mt.y)),
           "-x" = (file.access(x, 1L) == 0L),
           stop(gettextf("test '%s' is not available", op),
                domain = NA))
}

### ** list_files_with_exts

list_files_with_exts <-
function(dir, exts, all.files = FALSE, full.names = TRUE)
{
    ## Return the paths or names of the files in @code{dir} with
    ## extension in @code{exts}.
    ## Might be in a zipped dir on Windows.
    if(file.exists(file.path(dir, "filelist")) &&
       any(file.exists(file.path(dir, c("Rdata.zip", "Rex.zip", "Rhelp.zip")))))
    {
        files <- readLines(file.path(dir, "filelist"))
        if(!all.files)
            files <- grep("^[^.]", files, value = TRUE)
    } else {
        files <- list.files(dir, all.files = all.files)
    }
    ## does not cope with exts with '.' in.
    ## files <- files[sub(".*\\.", "", files) %in% exts]
    patt <- paste0("\\.(", paste(exts, collapse="|"), ")$")
    files <- grep(patt, files, value = TRUE)
    if(full.names)
        files <- if(length(files))
            file.path(dir, files)
        else
            character()
    files
}

### ** list_files_with_type

list_files_with_type <-
function(dir, type, all.files = FALSE, full.names = TRUE,
         OS_subdirs = .OStype())
{
    ## Return a character vector with the paths of the files in
    ## @code{dir} of type @code{type} (as in .make_file_exts()).
    ## When listing R code and documentation files, files in OS-specific
    ## subdirectories are included (if present) according to the value
    ## of @code{OS_subdirs}.

    exts <- .make_file_exts(type)
    files <-
        list_files_with_exts(dir, exts, all.files = all.files,
                             full.names = full.names)

    if(type %in% c("code", "docs")) {
        for(os in OS_subdirs) {
            os_dir <- file.path(dir, os)
            if(file_test("-d", os_dir)) {
                os_files <- list_files_with_exts(os_dir, exts,
                                                 all.files = all.files,
                                                 full.names = FALSE)
                os_files <- file.path(if(full.names) os_dir else os,
                                      os_files)
                files <- c(files, os_files)
            }
        }
    }
    ## avoid ranges since they depend on the collation order in the locale.
    ## in particular, Estonian sorts Z after S.
    if(type %in% c("code", "docs")) { # only certain filenames are valid.
        files <- files[grep("^[ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789]", basename(files))]
    }
    if(type %in% "demo") {           # only certain filenames are valid.
        files <- files[grep("^[ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz]", basename(files))]
    }
    files
}

### ** showNonASCII

showNonASCII <-
function(x)
{
    ## All that is needed here is an 8-bit encoding that includes ASCII.
    ## The only one we guarantee to exist is 'latin1'.
    ## The default sub=NA is faster, but on some platforms
    ## some characters used just to lose their accents, so two tests.
    asc <- iconv(x, "latin1", "ASCII")
    ind <- is.na(asc) | asc != x
    if(any(ind))
        cat(paste0(which(ind), ": ", iconv(x[ind], "latin1", "ASCII", sub = "byte")),
            sep = "\n")
    invisible(x[ind])
}

showNonASCIIfile <-
function(file)
    showNonASCII(readLines(file, warn = FALSE))

### * Text utilities.

### ** delimMatch

delimMatch <-
function(x, delim = c("{", "}"), syntax = "Rd")
{
    if(!is.character(x))
        stop("argument 'x' must be a character vector")
    ## FIXME: bytes or chars?
    if((length(delim) != 2L) || any(nchar(delim) != 1L))
        stop("argument 'delim' must specify two characters")
    if(syntax != "Rd")
        stop("only Rd syntax is currently supported")

    .Call(delim_match, x, delim)
}


### * LaTeX utilities

### ** texi2pdf
texi2pdf <-
function(file, clean = FALSE, quiet = TRUE,
         texi2dvi = getOption("texi2dvi"),
         texinputs = NULL, index = TRUE)
    texi2dvi(file = file, pdf = TRUE, clean = clean, quiet = quiet,
             texi2dvi = texi2dvi, texinputs = texinputs, index = index)

### ** texi2dvi

texi2dvi <-
function(file, pdf = FALSE, clean = FALSE, quiet = TRUE,
         texi2dvi = getOption("texi2dvi"),
         texinputs = NULL, index = TRUE)
{
    if (clean) pre_files <- list.files(all.files = TRUE)
    do_cleanup <- function(clean)
        if(clean) {
            ## output file will be created in the current directory
            out_file <- paste(basename(file_path_sans_ext(file)),
                              if(pdf) "pdf" else "dvi", sep = ".")
            files <- setdiff(list.files(all.files = TRUE),
                             c(".", "..", out_file, pre_files))
            file.remove(files)
        }

    ## Run texi2dvi on a latex file, or emulate it.

    if(is.null(texi2dvi) || !nzchar(texi2dvi) || texi2dvi == "texi2dvi")
        texi2dvi <- Sys.which("texi2dvi")

    envSep <- .Platform$path.sep
    texinputs0 <- texinputs
    Rtexmf <- file.path(R.home("share"), "texmf")
    Rtexinputs <- file.path(Rtexmf, "tex", "latex")
    ## "" forces use of default paths.
    texinputs <- paste(c(texinputs0, Rtexinputs, ""),
                       collapse = envSep)
    ## not clear if this is needed, but works
    if(.Platform$OS.type == "windows")
        texinputs <- gsub("\\", "/", texinputs, fixed = TRUE)
    Rbibinputs <- file.path(Rtexmf, "bibtex", "bib")
    bibinputs <- paste(c(texinputs0, Rbibinputs, ""),
                       collapse = envSep)
    Rbstinputs <- file.path(Rtexmf, "bibtex", "bst")
    bstinputs <- paste(c(texinputs0, Rbstinputs, ""),
                       collapse = envSep)

    otexinputs <- Sys.getenv("TEXINPUTS", unset = NA)
    if(is.na(otexinputs)) {
        on.exit(Sys.unsetenv("TEXINPUTS"))
        otexinputs <- "."
    } else on.exit(Sys.setenv(TEXINPUTS = otexinputs))
    Sys.setenv(TEXINPUTS = paste(otexinputs, texinputs, sep = envSep))
    obibinputs <- Sys.getenv("BIBINPUTS", unset = NA)
    if(is.na(obibinputs)) {
        on.exit(Sys.unsetenv("BIBINPUTS"), add = TRUE)
        obibinputs <- "."
    } else on.exit(Sys.setenv(BIBINPUTS = obibinputs, add = TRUE))
    Sys.setenv(BIBINPUTS = paste(obibinputs, bibinputs, sep = envSep))
    obstinputs <- Sys.getenv("BSTINPUTS", unset = NA)
    if(is.na(obstinputs)) {
        on.exit(Sys.unsetenv("BSTINPUTS"), add = TRUE)
        obstinputs <- "."
    } else on.exit(Sys.setenv(BSTINPUTS = obstinputs), add = TRUE)
    Sys.setenv(BSTINPUTS = paste(obstinputs, bstinputs, sep = envSep))

    if(index && nzchar(texi2dvi) && .Platform$OS.type != "windows") {
        ## switch off the use of texindy in texi2dvi >= 1.157
        Sys.setenv(TEXINDY = "false")
        on.exit(Sys.unsetenv("TEXINDY"), add = TRUE)
        opt_pdf <- if(pdf) "--pdf" else ""
        opt_quiet <- if(quiet) "--quiet" else ""
        opt_extra <- ""
        out <- .system_with_capture(texi2dvi, "--help")
        if(length(grep("--no-line-error", out$stdout)))
            opt_extra <- "--no-line-error"
        ## This is present in texinfo after late 2009, so really 5.x.
        if(length(grep("--max-iterations=N", out$stdout)))
            opt_extra <- c(opt_extra, "--max-iterations=20")
        ## (Maybe change eventually: the current heuristics for finding
        ## error messages in log files should work for both regular and
        ## file line error indicators.)

        ## and work around a bug in texi2dvi
        ## https://stat.ethz.ch/pipermail/r-devel/2011-March/060262.html
        ## That has [A-Za-z], earlier versions [A-z], both of which may be
        ## invalid in some locales.
        env0 <- "LC_COLLATE=C"
        ## texi2dvi, at least on OS X (4.8) does not accept TMPDIR with spaces.
        if (grepl(" ", Sys.getenv("TMPDIR")))
            env0 <- paste(env0,  "TMPDIR=/tmp")
        out <- .system_with_capture(texi2dvi,
                                    c(opt_pdf, opt_quiet, opt_extra,
                                      shQuote(file)),
                                    env = env0)

        ## We cannot necessarily rely on out$status, hence let us
        ## analyze the log files in any case.
        errors <- character()
        ## (La)TeX errors.
        log <- paste(file_path_sans_ext(file), "log", sep = ".")
        if(file_test("-f", log)) {
            lines <- .get_LaTeX_errors_from_log_file(log)
            if(length(lines))
                errors <- paste("LaTeX errors:",
                                paste(lines, collapse = "\n"),
                                sep = "\n")
        }
        ## BibTeX errors.
        log <- paste(file_path_sans_ext(file), "blg", sep = ".")
        if(file_test("-f", log)) {
            lines <- .get_BibTeX_errors_from_blg_file(log)
            if(length(lines))
                errors <- paste("BibTeX errors:",
                                paste(lines, collapse = "\n"),
                                sep = "\n")
        }

        msg <- ""
        if(out$status) {
            ## <NOTE>
            ## If we cannot rely on out$status, we could test for
            ##   if(out$status || length(errors))
            ## But shouldn't we be able to rely on out$status on Unix?
            ## </NOTE>
            msg <- gettextf("Running 'texi2dvi' on '%s' failed.", file)
            ## Error messages from GNU texi2dvi are rather terse, so
            ## only use them in case no additional diagnostics are
            ## available (e.g, makeindex errors).
            if(length(errors))
                msg <- paste(msg, errors, sep = "\n")
            else if(length(out$stderr))
                msg <- paste(msg, "Messages:",
                             paste(out$stderr, collapse = "\n"),
                             sep = "\n")
            if(!quiet)
                msg <- paste(msg, "Output:",
                             paste(out$stdout, collapse = "\n"),
                             sep = "\n")
        }

        do_cleanup(clean)

        if(nzchar(msg))
            stop(msg, domain = NA)
        else if(!quiet)
            message(paste(paste(out$stderr, collapse = "\n"),
                          paste(out$stdout, collapse = "\n"),
                          sep = "\n"))
    } else if(index && nzchar(texi2dvi)) { # MiKTeX on Windows
        extra <- ""

        ## look for MiKTeX (which this almost certainly is)
        ## and set the path to R's style files.
        ## -I works in MiKTeX >= 2.4, at least
        ## http://docs.miktex.org/manual/texify.html
        ver <- system(paste(shQuote(texi2dvi), "--version"), intern = TRUE)
        if(length(grep("MiKTeX", ver[1L]))) {
            ## AFAICS need separate -I for each element of texinputs.
            texinputs <- c(texinputs0, Rtexinputs, Rbstinputs)
            texinputs <- gsub("\\", "/", texinputs, fixed = TRUE)
            paths <- paste ("-I", shQuote(texinputs))
            extra <- "--max-iterations=20"
           extra <- paste(extra, paste(paths, collapse = " "))
        }
        ## 'file' could be a file path
        base <- basename(file_path_sans_ext(file))
        ## this only gives a failure in some cases, e.g. not for bibtex errors.
        system(paste(shQuote(texi2dvi),
                     if(quiet) "--quiet" else "",
                     if(pdf) "--pdf" else "",
                     shQuote(file), extra),
               intern=TRUE, ignore.stderr=TRUE)
        msg <- ""
        ## (La)TeX errors.
        logfile <- paste(base, "log", sep = ".")
        if(file_test("-f", logfile)) {
            lines <- .get_LaTeX_errors_from_log_file(logfile)
            if(length(lines))
                msg <- paste(msg, "LaTeX errors:",
                             paste(lines, collapse = "\n"),
                             sep = "\n")
        }
        ## BibTeX errors.
        logfile <- paste(base, "blg", sep = ".")
        if(file_test("-f", logfile)) {
            lines <- .get_BibTeX_errors_from_blg_file(logfile)
            if(length(lines))
                msg <- paste(msg, "BibTeX errors:",
                             paste(lines, collapse = "\n"),
                             sep = "\n")
        }

        do_cleanup(clean)
        if(nzchar(msg)) {
            msg <- paste(gettextf("running 'texi2dvi' on '%s' failed", file),
                         msg, "", sep = "\n")
            stop(msg, call. = FALSE, domain = NA)
        }
    } else {
        ## Do not have texi2dvi or don't want to index
        ## Needed on Windows except for MiKTeX
        ## Note that this does not do anything about running quietly,
        ## nor cleaning, but is probably not used much anymore.

        ## If it is called with MiKTeX then TEXINPUTS etc will be ignored.

        texfile <- shQuote(file)
        ## 'file' could be a file path
        base <- basename(file_path_sans_ext(file))
        idxfile <- paste0(base, ".idx")
        latex <- if(pdf) Sys.getenv("PDFLATEX", "pdflatex")
        else  Sys.getenv("LATEX", "latex")
        if(!nzchar(Sys.which(latex)))
            stop(if(pdf) "pdflatex" else "latex", " is not available",
                 domain = NA)
        bibtex <- Sys.getenv("BIBTEX", "bibtex")
        makeindex <- Sys.getenv("MAKEINDEX", "makeindex")
        if(system(paste(shQuote(latex), "-interaction=nonstopmode", texfile)))
            stop(gettextf("unable to run '%s' on '%s'", latex, file),
                 domain = NA)
        nmiss <- length(grep("^LaTeX Warning:.*Citation.*undefined",
                             readLines(paste0(base, ".log"))))
        for(iter in 1L:10L) { ## safety check
            ## This might fail as the citations have been included in the Rnw
            if(nmiss) system(paste(shQuote(bibtex), shQuote(base)))
            nmiss_prev <- nmiss
            if(index && file.exists(idxfile)) {
                if(system(paste(shQuote(makeindex), shQuote(idxfile))))
                    stop(gettextf("unable to run '%s' on '%s'",
                                  makeindex, idxfile),
                         domain = NA)
            }
            if(system(paste(shQuote(latex), "-interaction=nonstopmode", texfile)))
                stop(gettextf("unable to run %s on '%s'", latex, file), domain = NA)
            Log <- readLines(paste0(base, ".log"))
            nmiss <- length(grep("^LaTeX Warning:.*Citation.*undefined", Log))
            if(nmiss == nmiss_prev &&
               !length(grep("Rerun to get", Log)) ) break
        }
        do_cleanup(clean)
    }
    invisible(NULL)
}

### * Internal utility variables.

### ** .BioC_version_associated_with_R_version

.BioC_version_associated_with_R_version <-
    numeric_version(Sys.getenv("R_BIOC_VERSION", "2.14"))
## Things are more complicated from R-2.15.x with still two BioC
## releases a year, so we do need to set this manually.

### ** .vc_dir_names

## Version control directory names: CVS, .svn (Subversion), .arch-ids
## (arch), .bzr, .git, .hg (mercurial) and _darcs (Darcs)
## And it seems .metadata (eclipse) is in the same category.

.vc_dir_names <-
    c("CVS", ".svn", ".arch-ids", ".bzr", ".git", ".hg", "_darcs", ".metadata")

## and RE version (beware of the need for escapes if amending)

.vc_dir_names_re <-
    "/(CVS|\\.svn|\\.arch-ids|\\.bzr|\\.git|\\.hg|_darcs|\\.metadata)(/|$)"

## We are told
## .Rproj.user is Rstudio
## .cproject .project .settings are Eclipse
## .exrc is for vi
## .tm_properties is Mac's TextMate
.hidden_file_exclusions <-
    c(".Renviron", ".Rprofile", ".Rproj.user",
      ".Rhistory", ".Rapp.history",
      ".tex", ".log", ".aux", ".pdf", ".png",
      ".backups", ".cvsignore", ".cproject", ".directory",
      ".dropbox", ".exrc", ".gdb.history",
      ".gitattributes", ".gitignore", ".gitmodules",
      ".hgignore", ".hgtags",
      ".htaccess",
      ".latex2html-init",
      ".project", ".seed", ".settings", ".tm_properties")

### * Internal utility functions.

### ** %w/o%

## x without y, as in the examples of ?match.
`%w/o%` <-
function(x, y)
    x[!x %in% y]

### ** .OStype

.OStype <-
function()
{
    OS <- Sys.getenv("R_OSTYPE")
    if(nzchar(OS)) OS else .Platform$OS.type
}

### .R_top_srcdir

## Find the root directory of the source tree used for building this
## version of R (corresponding to Unix configure @top_srcdir@).
## Seems this is not recorded anywhere, but we can find our way ...

.R_top_srcdir_from_Rd <-
function() {
    filebase <-
        file_path_sans_ext(system.file("help", "tools.rdb",
                                       package = "tools"))
    path <- attr(fetchRdDB(filebase, "QC"), "Rdfile")
    ## We could use 5 dirname() calls, but perhaps more easily:
    substring(path, 1L, nchar(path) - 28L)
}

## Unfortunately,
##   .R_top_srcdir <- .R_top_srcdir_from_Rd()
## does not work because when tools is installed there are no Rd pages
## yet ...

### ** config_val_to_logical

config_val_to_logical <-
function(val) {
    v <- tolower(val)
    if (v %in% c("1", "yes", "true")) TRUE
    else if (v %in% c("0", "no", "false")) FALSE
    else {
        warning("cannot coerce ", sQuote(val), " to logical")
        NA
    }
}

### ** .eval_with_capture

.eval_with_capture <-
function(expr, type = NULL)
{
    ## Evaluate the given expression and return a list with elements
    ## 'value', 'output' and 'message' (with obvious meanings).

    ## <NOTE>
    ## The current implementation gives character() if capturing was not
    ## attempted of gave nothing.  If desired, one could modify the code
    ## to return NULL in the former case.
    ## </NOTE>

    if(is.null(type))
        capture_output <- capture_message <- TRUE
    else {
        type <- match.arg(type, c("output", "message"))
        capture_output <- type == "output"
        capture_message <- !capture_output
    }

    outcon <- file(open = "w+", encoding = "UTF-8")
    msgcon <- file(open = "w+", encoding = "UTF-8")
    if(capture_output) {
        sink(outcon, type = "output")
        on.exit(sink(type = "output"))
    }
    if(capture_message) {
        sink(msgcon, type = "message")
        on.exit(sink(type = "message"), add = capture_output)
    }
    on.exit({ close(outcon) ; close(msgcon) }, add = TRUE)

    value <- eval(expr)
    list(value = value,
         output = readLines(outcon, encoding = "UTF-8", warn = FALSE),
         message = readLines(msgcon, encoding = "UTF-8", warn = FALSE))
}


### ** .file_append_ensuring_LFs

.file_append_ensuring_LFs <-
function(file1, file2)
{
    ## Use a fast version of file.append() that ensures LF between
    ## files.
    .Call(codeFilesAppend, file1, file2)
}

### ** .file_path_relative_to_dir

.file_path_relative_to_dir <-
function(x, dir)
{
    if(any(ind <- (substring(x, 1L, nchar(dir)) == dir))) {
        ## Assume .Platform$file.sep is a single character.
        x[ind] <- substring(x, nchar(dir) + 2L)
    }
    x
}

### ** .find_calls

.find_calls <-
function(x, predicate = NULL, recursive = FALSE)
{
    x <- as.list(x)

    f <- if(is.null(predicate))
        function(e) is.call(e)
    else
        function(e) is.call(e) && predicate(e)

    if(!recursive) return(Filter(f, x))

    calls <- list()
    gatherer <- function(e) {
        if(f(e)) calls <<- c(calls, list(e))
        if(is.recursive(e))
            for(i in seq_along(e)) gatherer(e[[i]])
    }
    gatherer(x)

    calls
}

### ** .find_calls_in_file

.find_calls_in_file <-
function(file, encoding = NA, predicate = NULL, recursive = FALSE)
{
    .find_calls(.parse_code_file(file, encoding), predicate, recursive)
}

### ** .find_calls_in_package_code

.find_calls_in_package_code <-
function(dir, predicate = NULL, recursive = FALSE, .worker = NULL)
{
    dir <- file_path_as_absolute(dir)

    dfile <- file.path(dir, "DESCRIPTION")
    encoding <- if(file.exists(dfile))
        .read_description(dfile)["Encoding"] else NA

    if(is.null(.worker))
        .worker <- function(file, encoding)
            .find_calls_in_file(file, encoding, predicate, recursive)

    code_files <-
        list_files_with_type(file.path(dir, "R"), "code",
                             OS_subdirs = c("unix", "windows"))
    calls <- lapply(code_files, .worker, encoding)
    names(calls) <-
        .file_path_relative_to_dir(code_files, dirname(dir))

    calls
}

### ** .find_owner_env

.find_owner_env <-
function(v, env, last = NA, default = NA) {
    while(!identical(env, last))
        if(exists(v, envir = env, inherits = FALSE))
            return(env)
        else
            env <- parent.env(env)
    default
}

### ** .get_BibTeX_errors_from_blg_file

.get_BibTeX_errors_from_blg_file <-
function(con)
{
    ## Get BibTeX error info, using non-header lines until the first
    ## warning or summary, hoping for the best ...
    lines <- readLines(con, warn = FALSE)
    if(any(ind <- is.na(nchar(lines, allowNA = TRUE))))
        lines[ind] <- iconv(lines[ind], "", "", sub = "byte")

    ## How can we find out for sure that there were errors?  Try
    ## guessing ... and peeking at tex-buf.el from AUCTeX.
    really_has_errors <-
        (length(grep("^---", lines)) ||
         regexpr("There (was|were) ([0123456789]+) error messages?",
                 lines[length(lines)]) > -1L)
    ## (Note that warnings are ignored for now.)
    ## MiKTeX does not give usage, so '(There were n error messages)' is
    ## last.
    pos <- grep("^(Warning|You|\\(There)", lines)
    if(!really_has_errors || !length(pos) ) return(character())
    ind <- seq.int(from = 3L, length.out = pos[1L] - 3L)
    lines[ind]
}

### ** .get_LaTeX_errors_from_log_file

.get_LaTeX_errors_from_log_file <-
function(con, n = 4L)
{
    ## Get (La)TeX lines with error plus n (default 4) lines of trailing
    ## context.
    lines <- readLines(con, warn = FALSE)
    if(any(ind <- is.na(nchar(lines, allowNA = TRUE))))
        lines[ind] <- iconv(lines[ind], "", "", sub = "byte")

    ## Try matching both the regular error indicator ('!') as well as
    ## the file line error indicator ('file:line:').
    pos <- grep("(^! |^!pdfTeX error:|:[0123456789]+:.*[Ee]rror)", lines)
    ## unforunately that was too general and caught false positives
    ## Errors are typically of the form
    ## ! LaTeX Error:
    ## !pdfTeX error:
    ## ! Emergency stop
    ## !  ==> Fatal error occurred, no output PDF file produced!
    ## .../pegas.Rcheck/inst/doc/ReadingFiles.tex:395: Package inputenc Error:
    if(!length(pos)) return(character())
    ## Error chunk extends to at most the next error line.
    mapply(function(from, to) paste(lines[from : to], collapse = "\n"),
           pos, pmin(pos + n, c(pos[-1L], length(lines))))
}

### ** .get_internal_S3_generics

.get_internal_S3_generics <-
function(primitive = TRUE) # primitive means 'include primitives'
{
    out <-
        ## Get the names of R internal S3 generics (via DispatchOrEval(),
        ## cf. zMethods.Rd).
        c("[", "[[", "$", "[<-", "[[<-", "$<-",
          "as.vector", "unlist",
          .get_S3_primitive_generics()
          ## ^^^^^^^ now contains the members of the group generics from
          ## groupGeneric.Rd.
          )
    if(!primitive)
        out <- out[!vapply(out, .is_primitive_in_base, NA)]
    out
}

### ** .get_namespace_package_depends

.get_namespace_package_depends <-
function(dir)
{
    nsInfo <- .check_namespace(dir)
    depends <- c(sapply(nsInfo$imports, "[[", 1L),
                 sapply(nsInfo$importClasses, "[[", 1L),
                 sapply(nsInfo$importMethods, "[[", 1L))
    unique(sort(as.character(depends)))
}

### ** .get_namespace_S3_methods_db

.get_namespace_S3_methods_db <-
function(nsInfo)
{
    ## Get the registered S3 methods for an 'nsInfo' object returned by
    ## parseNamespaceFile(), as a 3-column character matrix with the
    ## names of the generic, class and method (as a function).
    S3_methods_list <- nsInfo$S3methods
    if(!length(S3_methods_list)) return(matrix(character(), ncol = 3L))
    idx <- is.na(S3_methods_list[, 3L])
    S3_methods_list[idx, 3L] <-
        paste(S3_methods_list[idx, 1L],
              S3_methods_list[idx, 2L],
              sep = ".")
    S3_methods_list
}

### ** .get_package_metadata

.get_package_metadata <-
function(dir, installed = FALSE)
{
    ## Get the package DESCRIPTION metadata for a package with root
    ## directory 'dir'.  If an unpacked source (uninstalled) package,
    ## base packages (have only a DESCRIPTION.in file with priority
    ## "base") need special attention.
    dir <- file_path_as_absolute(dir)
    dfile <- file.path(dir, "DESCRIPTION")
    if(file_test("-f", dfile)) return(.read_description(dfile))
    if(installed) stop("File 'DESCRIPTION' is missing.")
    dfile <- file.path(dir, "DESCRIPTION.in")
    if(file_test("-f", dfile))
        meta <- .read_description(dfile)
    else
        stop("Files 'DESCRIPTION' and 'DESCRIPTION.in' are missing.")
    if(identical(as.character(meta["Priority"]), "base")) return(meta)
    stop("invalid package layout")
}

### ** .get_requires_from_package_db

.get_requires_from_package_db <-
function(db,
         category = c("Depends", "Imports", "LinkingTo", "Suggests", "Enhances"))
{
    category <- match.arg(category)
    if(category %in% names(db)) {
        requires <- unlist(strsplit(db[category], ","))
        requires <-
            sub("^[[:space:]]*([[:alnum:].]+).*$", "\\1", requires)
        if(category == "Depends")
            requires <- requires[requires != "R"]
    }
    else
        requires <- character()
    requires
}

### ** .get_requires_with_version_from_package_db

.get_requires_with_version_from_package_db <-
function(db,
         category = c("Depends", "Imports", "LinkingTo", "Suggests", "Enhances"))
{
    category <- match.arg(category)
    if(category %in% names(db)) {
        res <- .split_dependencies(db[category])
        if(category == "Depends") res[names(res) != "R"] else res
    } else list()
}

### ** .get_S3_generics_as_seen_from_package

.get_S3_generics_as_seen_from_package <-
function(dir, installed = TRUE, primitive = FALSE)
{
    ## Get the S3 generics "as seen from a package" rooted at
    ## @code{dir}.  Tricky ...
    if(basename(dir) == "base")
        env_list <- list()
    else {
        ## Always look for generics in the whole of the former base.
        ## (Not right, but we do not perform run time analyses when
        ## working off package sources.)  Maybe change this eventually,
        ## but we still cannot rely on packages to fully declare their
        ## dependencies on base packages.
        env_list <-
            list(baseenv(),
                 as.environment("package:graphics"),
                 as.environment("package:stats"),
                 as.environment("package:utils"))
        if(installed) {
            ## Also use the loaded namespaces and attached packages
            ## listed in the DESCRIPTION Depends and Imports fields.
            ## Not sure if this is the best approach: we could also try
            ## to determine which namespaces/packages were made
            ## available by loading the package (which should work at
            ## least when run from R CMD check), or we could simply
            ## attach every package listed as a dependency ... or
            ## perhaps do both.
            db <- .read_description(file.path(dir, "DESCRIPTION"))
            depends <- .get_requires_from_package_db(db, "Depends")
            imports <- .get_requires_from_package_db(db, "Imports")
            reqs <- intersect(c(depends, imports), loadedNamespaces())
            if(length(reqs))
                env_list <- c(env_list, lapply(reqs, getNamespace))
            reqs <- intersect(setdiff(depends, loadedNamespaces()),
                              .packages())
            if(length(reqs))
                env_list <- c(env_list, lapply(reqs, .package_env))
            env_list <- unique(env_list)
        }
    }
    unique(c(.get_internal_S3_generics(primitive),
             unlist(lapply(env_list,
                           function(env) {
                               nms <- objects(envir = env,
                                              all.names = TRUE)
                               if(".no_S3_generics" %in% nms)
                                   character()
                               else Filter(function(f)
                                           .is_S3_generic(f, envir = env),
                                           nms)
                           }))))
}

### ** .get_S3_group_generics

.get_S3_group_generics <-
function()
    c("Ops", "Math", "Summary", "Complex")

### ** .get_S3_primitive_generics

.get_S3_primitive_generics <-
function(include_group_generics = TRUE)
{
    if(include_group_generics)
        c(base::.S3PrimitiveGenerics,
          "abs", "sign", "sqrt", "floor", "ceiling", "trunc", "round",
          "signif", "exp", "log", "expm1", "log1p",
          "cos", "sin", "tan", "acos", "asin", "atan",
          "cosh", "sinh", "tanh", "acosh", "asinh", "atanh",
          "lgamma", "gamma", "digamma", "trigamma",
          "cumsum", "cumprod", "cummax", "cummin",
          "+", "-", "*", "/", "^", "%%", "%/%", "&", "|", "!", "==",
          "!=", "<", "<=", ">=", ">",
          "all", "any", "sum", "prod", "max", "min", "range",
          "Arg", "Conj", "Im", "Mod", "Re")
    else
        base::.S3PrimitiveGenerics
}

### ** .get_standard_Rd_keywords

.get_standard_Rd_keywords <-
function()
{
    lines <- readLines(file.path(R.home("doc"), "KEYWORDS.db"))
    lines <- grep("^.*\\|([^:]*):.*", lines, value = TRUE)
    lines <- sub( "^.*\\|([^:]*):.*", "\\1", lines)
    lines
}

### ** .get_standard_package_names

## we cannot assume that file.path(R.home("share"), "make", "vars.mk")
## is installed, as it is not on Windows
.get_standard_package_names <-
local({
    lines <- readLines(file.path(R.home("share"), "make", "vars.mk"))
    lines <- grep("^R_PKGS_[[:upper:]]+ *=", lines, value = TRUE)
    out <- strsplit(sub("^R_PKGS_[[:upper:]]+ *= *", "", lines), " +")
    names(out) <-
        tolower(sub("^R_PKGS_([[:upper:]]+) *=.*", "\\1", lines))
    eval(substitute(function() {out}, list(out=out)), envir=NULL)
})

### ** .get_standard_repository_URLs

.get_standard_repository_URLs <-
function()
{
    repos <- Sys.getenv("_R_CHECK_XREFS_REPOSITORIES_", "")
    if(nzchar(repos)) {
        repos <-
            .expand_BioC_repository_URLs(strsplit(repos, " +")[[1L]])
    } else {
        nms <- c("CRAN", "BioCsoft", "BioCann", "BioCexp")
        repos <- getOption("repos")
        ## This is set by utils:::.onLoad(), hence may be NULL.
        if(!is.null(repos) &&
           !any(is.na(repos[nms])) &&
           (repos["CRAN"] != "@CRAN@"))
            repos <- repos[nms]
        else {
            p <- file.path(Sys.getenv("HOME"), ".R", "repositories")
            repos <- if(file_test("-f", p)) {
                a <- .read_repositories(p)
                a[nms, "URL"]
            } else {
                a <- .read_repositories(file.path(R.home("etc"),
                                                  "repositories"))
                c("http://CRAN.R-project.org", a[nms[-1L], "URL"])
            }
            names(repos) <- nms
        }
    }
    repos
}

### ** .get_standard_repository_db_fields

.get_standard_repository_db_fields <-
function(type = c("source", "mac.binary", "win.binary")) {
    type <- match.arg(type)
    c("Package", "Version", "Priority",
      "Depends", "Imports", "LinkingTo", "Suggests", "Enhances",
      "License", "License_is_FOSS", "License_restricts_use",
      "OS_type", "Archs", "MD5sum",
      if(type == "source") "NeedsCompilation"
      )
}

### ** .get_standard_DESCRIPTION_fields

.get_standard_DESCRIPTION_fields <-
function()
{
    unique(c(.get_standard_repository_db_fields(),
             ## Extract from R-exts via
             ## .get_DESCRIPTION_fields_in_R_exts():
             c("Author",
               "Authors@R",
               "Biarch",
               "BugReports",
               "BuildKeepEmpty",
               "BuildManual",
               "BuildResaveData",
               "BuildVignettes",
               "Built",
               "ByteCompile",
               "Classification/ACM",
               "Classification/JEL",
               "Classification/MSC",
               "Collate",
               "Collate.unix",
               "Collate.windows",
               "Contact",
               "Copyright",
               "Date",
               "Depends",
               "Description",
               "Encoding",
               "Enhances",
               "Imports",
               "KeepSource",
               "Language",
               "LazyData",
               "LazyDataCompression",
               "LazyLoad",
               "License",
               "LinkingTo",
               "MailingList",
               "Maintainer",
               "Note",
               "OS_type",
               "Package",
               "Packaged",
               "Priority",
               "Suggests",
               "SysDataCompression",
               "SystemRequirements",
               "Title",
               "Type",
               "URL",
               "Version",
               "VignetteBuilder",
               "ZipData"),
             ## Others: adjust as needed.
             c("Repository",
               "Path",
               "Date/Publication",
               "LastChangedDate",
               "LastChangedRevision",
               "Revision",
               "RcmdrModels",
               "RcppModules",
               "biocViews")
             ))
}

### ** .get_DESCRIPTION_fields_in_R_exts

.get_DESCRIPTION_fields_in_R_exts <-
function(texi = NULL)
{
    if(is.null(texi))
        texi <- file.path(.R_top_srcdir_from_Rd(),
                          "doc", "manual", "R-exts.texi")
    lines <- readLines(texi)
    re <- "^@c DESCRIPTION field "
    sort(unique(sub(re, "", lines[grepl(re, lines)])))
}

### ** .is_ASCII

.is_ASCII <-
function(x)
{
    ## Determine whether the strings in a character vector are ASCII or
    ## not.
    vapply(as.character(x), function(txt)
           all(charToRaw(txt) <= as.raw(127)), NA)
}

### ** .is_ISO_8859

.is_ISO_8859 <-
function(x)
{
    ## Determine whether the strings in a character vector could be in
    ## some ISO 8859 character set or not.
    raw_ub <- charToRaw("\x7f")
    raw_lb <- charToRaw("\xa0")
    vapply(as.character(x), function(txt) {
        raw <- charToRaw(txt)
        all(raw <= raw_ub | raw >= raw_lb)
    }, NA)
}

### ** .is_primitive_in_base

.is_primitive_in_base <-
function(fname)
{
    ## Determine whether object named 'fname' found in the base
    ## environment is a primitive function.
    is.primitive(get(fname, envir = baseenv(), inherits = FALSE))
}

### ** .is_S3_generic

.is_S3_generic <-
function(fname, envir, mustMatch = TRUE)
{
    ## Determine whether object named 'fname' found in environment
    ## 'envir' is (to be considered) an S3 generic function.  Note,
    ## found *in* not found *from*, so envir does not have a default.
    ##
    ## If it is, does it despatch methods of fname?  We need that to
    ## look for possible methods as functions named fname.* ....
    ##
    ## Provided by LT with the following comments:
    ##
    ## This is tricky.  Figuring out what could possibly dispatch
    ## successfully some of the time is pretty much impossible given R's
    ## semantics.  Something containing a literal call to UseMethod is
    ## too broad in the sense that a UseMethod call in a local function
    ## doesn't produce a dispatch on the outer function ...
    ##
    ## If we use something like: a generic has to be
    ##      function(e) <UME>  # UME = UseMethod Expression
    ## with
    ##      <UME> = UseMethod(...) |
    ##             if (...) <UME> [else ...] |
    ##             if (...) ... else <UME>
    ##             { ... <UME> ... }
    ## then a recognizer for UME might be as follows.

    f <- suppressMessages(get(fname, envir = envir, inherits = FALSE))
    if(!is.function(f)) return(FALSE)
    isUMEbrace <- function(e) {
        for (ee in as.list(e[-1L])) if (nzchar(res <- isUME(ee))) return(res)
        ""
    }
    isUMEif <- function(e) {
        if (length(e) == 3L) isUME(e[[3L]])
        else {
            if (nzchar(res <- isUME(e[[3L]]))) res
            else if (nzchar(res <- isUME(e[[4L]]))) res
            else ""
        }

    }
    isUME <- function(e) {
        if (is.call(e) && (is.name(e[[1L]]) || is.character(e[[1L]]))) {
            switch(as.character(e[[1L]]),
                   UseMethod = as.character(e[[2L]]),
                   "{" = isUMEbrace(e),
                   "if" = isUMEif(e),
                   "")
        } else ""
    }
    res <- isUME(body(f))
    if(mustMatch) res == fname else nzchar(res)
}

### ** .load_package_quietly

.load_package_quietly <-
function(package, lib.loc)
{
    ## Load (reload if already loaded) @code{package} from
    ## @code{lib.loc}, capturing all output and messages.
    ## Don't do anything for base.
    ## Earlier versions did not attempt reloading methods as this used
    ## to cause trouble, but this now (2009-03-19) seems ok.
    ## Otoh, it seems that unloading tcltk is a bad idea ...
    ## Also, do not unload ourselves (but shouldn't we be "in use"?).
    ##
    ## All QC functions use this for loading packages because R CMD
    ## check interprets all output as indicating a problem.
    if(package != "base")
        .try_quietly({
            pos <- match(paste("package", package, sep = ":"), search())
            if(!is.na(pos)) {
                detach(pos = pos,
                       unload = ! package %in% c("tcltk", "tools"))
            }
            library(package, lib.loc = lib.loc, character.only = TRUE,
                    verbose = FALSE)
        })
}

### ** .make_file_exts

## <FIXME>
## Remove support for type "vignette" eventually ...
## </FIXME>

.make_file_exts <-
function(type = c("code", "data", "demo", "docs", "vignette"))
{
    ## Return a character vector with the possible/recognized file
    ## extensions for a given file type.
    switch(type,
           code = c("R", "r", "S", "s", "q"),
           ## Keep in sync with the order given in base's data.Rd.
           data = c("R", "r",
                    "RData", "rdata", "rda",
                    "tab", "txt", "TXT",
                    "tab.gz", "txt.gz",
                    "tab.bz2", "txt.bz2",
                    "tab.xz", "txt.xz",
                    "csv", "CSV",
                    "csv.gz", "csv.bz2", "csv.xz"),
           demo = c("R", "r"),
           docs = c("Rd", "rd", "Rd.gz", "rd.gz"),
           vignette = c(outer(c("R", "r", "S", "s"), c("nw", "tex"),
                              paste, sep = ""), "Rmd"))
}

### ** .make_S3_group_generic_env

.make_S3_group_generic_env <-
function(parent = parent.frame())
{
    ## Create an environment with pseudo-definitions for the S3 group
    ## methods.
    env <- new.env(parent = parent) # small
    assign("Math", function(x, ...) UseMethod("Math"),
           envir = env)
    assign("Ops", function(e1, e2) UseMethod("Ops"),
           envir = env)
    assign("Summary", function(..., na.rm = FALSE) UseMethod("Summary"),
           envir = env)
    assign("Complex", function(z) UseMethod("Complex"),
           envir = env)
    env
}

### ** .make_S3_primitive_generic_env

.make_S3_primitive_generic_env <-
function(parent = parent.frame(), fixup = FALSE)
{
    ## Create an environment with pseudo-definitions for the S3 primitive
    ## generics
    env <- new.env(hash = TRUE, parent = parent)
    for(f in ls(base::.GenericArgsEnv))
        assign(f, get(f, envir=base::.GenericArgsEnv), envir = env)
    if(fixup) {
        ## now fixup the operators
        for(f in c('+', '-', '*', '/', '^', '%%', '%/%', '&', '|',
                   '==', '!=', '<', '<=', '>=', '>')) {
            fx <- get(f, envir = env)
            formals(fx) <- alist(x=, y=)
            assign(f, fx, envir = env)
        }
    }
    env
}

### ** .make_S3_primitive_nongeneric_env

.make_S3_primitive_nongeneric_env <-
function(parent = parent.frame())
{
    ## Create an environment with pseudo-definitions
    ## for the S3 primitive non-generics
    env <- new.env(hash = TRUE, parent = parent)
    for(f in ls(base::.ArgsEnv))
        assign(f, get(f, envir=base::.ArgsEnv), envir = env)
    env
}

### ** .make_S3_methods_stop_list

.make_S3_methods_stop_list <-
function(package)
{
    ## Return a character vector with the names of the functions in
    ## @code{package} which 'look' like S3 methods, but are not.
    ## Using package = NULL returns all known examples

    stopList <-
        list(base = c("all.equal", "all.names", "all.vars",
             "format.char", "format.info", "format.pval",
             "max.col",
             ## the next two only exist in *-defunct.Rd.
             "print.atomic", "print.coefmat",
             "qr.Q", "qr.R", "qr.X", "qr.coef", "qr.fitted", "qr.qty",
             "qr.qy", "qr.resid", "qr.solve",
             ## round.POSIXt is a method for S3 and S4 group generics with
             ## deliberately different arg names.
             "rep.int", "round.POSIXt",
             "seq.int", "sort.int", "sort.list"),
             AMORE = "sim.MLPnet",
             BSDA = "sign.test",
             ChemometricsWithR = "lda.loofun",
             ElectoGraph = "plot.wedding.cake",
             FrF2 = "all.2fis.clear.catlg",
             GLDEX = c("hist.su", "pretty.su"),
             Hmisc = c("abs.error.pred", "all.digits", "all.is.numeric",
                       "format.df", "format.pval", "t.test.cluster"),
             HyperbolicDist = "log.hist",
             MASS = c("frequency.polygon", "gamma.dispersion", "gamma.shape",
                      "hist.FD", "hist.scott"),
             ## FIXME: since these are already listed with 'base',
             ##        they should not need to be repeated here:
             Matrix = c("qr.Q", "qr.R", "qr.coef", "qr.fitted",
                        "qr.qty", "qr.qy", "qr.resid"),
             RCurl = "merge.list",
             RNetCDF = c("close.nc", "dim.def.nc", "dim.inq.nc",
                         "dim.rename.nc", "open.nc", "print.nc"),
             SMPracticals = "exp.gibbs",
             XML = "text.SAX",
             ape = "sort.index",
             arm = "sigma.hat", # lme4 has sigma()
             assist = "chol.new",
             boot = "exp.tilt",
             car = "scatterplot.matrix",
             calibrator = "t.fun",
             clusterfly = "ggobi.som",
             coda = "as.mcmc.list",
             crossdes = "all.combn",
             ctv = "update.views",
             deSolve = "plot.1D",
             equivalence = "sign.boot",
             fields = c("qr.q2ty", "qr.yq2"),
             gbm = c("pretty.gbm.tree", "quantile.rug"),
             gpclib = "scale.poly",
             grDevices = "boxplot.stats",
             graphics = c("close.screen", "plot.design", "plot.new",
                          "plot.window", "plot.xy", "split.screen"),
             ic.infer = "all.R2",
             hier.part = "all.regs",
             lasso2 = "qr.rtr.inv",
             latticeExtra = "xyplot.list",
             locfit = c("density.lf", "plot.eval"),
             moments = c("all.cumulants", "all.moments"),
             mosaic = "t.test",
             mratios = c("t.test.ration", "t.test.ratio.default",
                         "t.test.ratio.formula"),
             ncdf = c("open.ncdf", "close.ncdf",
                      "dim.create.ncdf", "dim.def.ncdf",
                      "dim.inq.ncdf", "dim.same.ncdf"),
             quadprog = c("solve.QP", "solve.QP.compact"),
             reposTools = "update.packages2",
             rgeos = "scale.poly",
             sac = "cumsum.test",
             sm = "print.graph",
             splusTimeDate = "sort.list",
             splusTimeSeries = "sort.list",
             stats = c("anova.lmlist", "fitted.values", "lag.plot",
                       "influence.measures", "t.test",
                       "plot.spec.phase", "plot.spec.coherency"),
             supclust = c("sign.change", "sign.flip"),
             tensorA = "chol.tensor",
             utils = c("close.socket", "flush.console", "update.packages")
             )
    if(is.null(package)) return(unlist(stopList))
    thisPkg <- stopList[[package]]
    if(!length(thisPkg)) character() else thisPkg
}

### ** .package_apply

.package_apply <-
function(packages = NULL, FUN, ...)
{
    ## Apply FUN and extra '...' args to all given packages.
    ## The default corresponds to all installed packages with high
    ## priority.
    if(is.null(packages))
        packages <-
            unique(utils::installed.packages(priority = "high")[ , 1L])
    out <- lapply(packages, function(p)
                  tryCatch(FUN(p, ...),
                           error = function(e)
                           noquote(paste("Error:",
                                         conditionMessage(e)))))
    ## (Just don't throw the error ...)
    names(out) <- packages
    out
}

### .parse_code_file

.parse_code_file <-
function(file, encoding = NA)
{
    if(!file.info(file)$size) return()
    suppressWarnings({
        if(!is.na(encoding) &&
           !(Sys.getlocale("LC_CTYPE") %in% c("C", "POSIX"))) {
            ## Previous use of con <- file(file, encoding = encoding)
            ## was intolerant so do what .install_package_code_files()
            ## does.
            lines <- iconv(readLines(file, warn = FALSE),
                           from = encoding, to = "", sub = "byte")
            parse(text = lines)
        } else parse(file)
    })
}


### ** .read_Rd_lines_quietly

.read_Rd_lines_quietly <-
function(con)
{
    ## Read lines from a connection to an Rd file, trying to suppress
    ## "incomplete final line found by readLines" warnings.
    if(is.character(con)) {
        con <- if(length(grep("\\.gz$", con))) gzfile(con, "r") else file(con, "r")
        on.exit(close(con))
    }
    .try_quietly(readLines(con, warn=FALSE))
}

### ** .read_collate_field

.read_collate_field <-
function(txt)
{
    ## Read Collate specifications in DESCRIPTION files.
    ## These consist of file paths relative to the R code directory,
    ## separated by white space, possibly quoted.  Note that we could
    ## have newlines in DCF entries but do not allow them in file names,
    ## hence we gsub() them out.
    con <- textConnection(gsub("\n", " ", txt))
    on.exit(close(con))
    scan(con, what = character(), strip.white = TRUE, quiet = TRUE)
}

### ** .read_description

.keep_white_description_fields <-
    c("Description", "Authors@R", "Author", "Built", "Packaged")

.read_description <-
function(dfile)
{
    ## Try reading in package metadata from a DESCRIPTION file.
    ## (Never clear whether this should work on the path of the file
    ## itself, or on that of the directory containing it.)
    ## <NOTE>
    ## As we do not have character "frames", we return a named character
    ## vector.
    ## </NOTE>
    if(!file_test("-f", dfile))
        stop(gettextf("file '%s' does not exist", dfile), domain = NA)
    out <- tryCatch(read.dcf(dfile,
                             keep.white =
                             .keep_white_description_fields),
                    error = function(e)
                    stop(gettextf("file '%s' is not in valid DCF format",
                                  dfile),
                         domain = NA, call. = FALSE))
    if (nrow(out) != 1)
        stop("contains a blank line", call. = FALSE)
    out <- out[1,]
    if(!is.na(encoding <- out["Encoding"])) {
        ## could convert everything to UTF-8
        if (encoding %in% c("latin1", "UTF-8"))
            Encoding(out) <- encoding
        else out <- iconv(out, encoding, "", sub = "byte")
    }
    out
}

.write_description <-
function(x, dfile)
{
    ## Invert how .read_description() handles package encodings.
    if(!is.na(encoding <- x["Encoding"])) {
        ## For UTF-8 or latin1 encodings, .read_description() would
        ## simply have marked the encoding.  But we might have added
        ## fields encoded differently ...
        ind <- is.na(match(Encoding(x), c(encoding, "unknown")))
        if(any(ind))
            x[ind] <- mapply(iconv, x[ind], Encoding(x)[ind], encoding,
                             sub = "byte")
    } else {
        ## If there is no declared encoding, we cannot have non-ASCII
        ## content.
        ## Cf. tools::showNonASCII():
        asc <- iconv(x, "latin1", "ASCII")
        ind <- is.na(asc) | (asc != x)
        if(any(ind)) {
            warning(gettext("Unknown encoding with non-ASCII data: converting to ASCII"),
                    domain = NA)
            x[ind] <- iconv(x[ind], "latin1", "ASCII", sub = "byte")
        }
    }
    ## Avoid declared encodings when writing out.
    Encoding(x) <- "unknown"
    ## Avoid folding for fields where we keep whitespace when reading.
    write.dcf(rbind(x), dfile,
              keep.white = c(.keep_white_description_fields, "Maintainer"))
}

### ** .read_repositories

.read_repositories <-
function(file)
{
    db <- utils::read.delim(file, header = TRUE, comment.char = "#",
                            colClasses =
                            c(rep.int("character", 3L),
                              rep.int("logical", 4L))) # allow for win64.binary
    db[, "URL"] <- .expand_BioC_repository_URLs(db[, "URL"])
    db
}

.expand_BioC_repository_URLs <-
function(x)
{
    x <- sub("%bm",
             as.character(getOption("BioC_mirror",
                                    "http://www.bioconductor.org")),
             x, fixed = TRUE)
    sub("%v",
        as.character(.BioC_version_associated_with_R_version),
        x, fixed = TRUE)
}

.expand_package_description_db_R_fields <-
function(x)
{
    enc <- x["Encoding"]
    y <- character()
    if(!is.na(aar <- x["Authors@R"])) {
        aar <- utils:::.read_authors_at_R_field(aar)
        if(is.na(x["Author"])) {
            tmp <- utils:::.format_authors_at_R_field_for_author(aar)
            ## uses strwrap, so will be in current locale
            if(!is.na(enc)) tmp <- iconv(tmp, "", enc)
            y["Author"] <- tmp
        }
        if(is.na(x["Maintainer"]))
            y["Maintainer"] <-
                utils:::.format_authors_at_R_field_for_maintainer(aar)
    }
    y
}

### ** .source_assignments

.source_assignments <-
function(file, envir, enc = NA)
{
    ## Read and parse expressions from @code{file}, and then
    ## successively evaluate the top-level assignments in @code{envir}.
    ## Apart from only dealing with assignments, basically does the same
    ## as @code{sys.source(file, envir, keep.source = FALSE)}.
    oop <- options(keep.source = FALSE)
    on.exit(options(oop))
    assignmentSymbolLM <- as.symbol("<-")
    assignmentSymbolEq <- as.symbol("=")
    if(!is.na(enc) &&
       !(Sys.getlocale("LC_CTYPE") %in% c("C", "POSIX"))) {
        con <- file(file, encoding = enc)
        on.exit(close(con))
    } else con <- file
    exprs <- parse(n = -1L, file = con)
    if(!length(exprs))
        return(invisible())
    for(e in exprs) {
        if(e[[1L]] == assignmentSymbolLM || e[[1L]] == assignmentSymbolEq)
            eval(e, envir)
    }
    invisible()
}

### .source_assignments_in_code_dir

.source_assignments_in_code_dir <-
function(dir, envir, meta = character())
{
    ## Combine all code files in @code{dir}, read and parse expressions,
    ## and successively evaluate the top-level assignments in @code{envir}.
    con <- tempfile("Rcode")
    on.exit(unlink(con))
    if(!file.create(con))
        stop("unable to create ", con)
    ## If the (DESCRIPTION) metadata contain a Collate specification,
    ## use this for determining the code files and their order.
    txt <- meta[c(paste("Collate", .OStype(), sep = "."), "Collate")]
    ind <- which(!is.na(txt))
    files <- if(any(ind))
        Filter(function(x) file_test("-f", x),
               file.path(dir, .read_collate_field(txt[ind[1L]])))
    else
        list_files_with_type(dir, "code")
    if(!all(.file_append_ensuring_LFs(con, files)))
        stop("unable to write code files")
    tryCatch(.source_assignments(con, envir, enc = meta["Encoding"]),
             error =
             function(e)
             stop("cannot source package code\n",
                  conditionMessage(e),
                  call. = FALSE))
}

### * .split_dependencies

.split_dependencies <-
function(x)
{
    ## given one or more Depends: or Suggests: fields from DESCRIPTION
    ## return a named list of list (name, [op, version])
    if(!length(x)) return(list())
    x <- unlist(strsplit(x, ","))
    ## some have had space before ,
    x <- sub('[[:space:]]+$', '', x)
    x <- unique(sub("^[[:space:]]*(.*)", "\\1" , x))
    names(x) <- sub("^([[:alnum:].]+).*$", "\\1" , x)
    lapply(x, .split_op_version)
}

### * .split_op_version

.split_op_version <-
function(x)
{
    ## given a single piece of dependency
    ## return a list of components (name, [op, version])
    ## NB this relies on trailing space having been removed
    pat <- "^([^\\([:space:]]+)[[:space:]]*\\(([^\\)]+)\\).*"
    x1 <- sub(pat, "\\1", x)
    x2 <- sub(pat, "\\2", x)
    if(x2 != x1) {
        pat <- "[[:space:]]*([[<>=!]+)[[:space:]]+(.*)"
        version <- sub(pat, "\\2", x2)
        if (!grepl("^r", version)) version <- package_version(version)
        list(name = x1, op = sub(pat, "\\1", x2), version = version)
    } else list(name = x1)
}

### ** .strip_whitespace

.strip_whitespace <-
function(x)
{
    ## Strip leading and trailing whitespace.
    x <- sub("^[[:space:]]+", "", x)
    x <- sub("[[:space:]]+$", "", x)
    x
}

### ** .system_with_capture

.system_with_capture <-
function(command, args = character(), env = character(),
         stdin = "", input = NULL)
{
    ## Invoke a system command and capture its status, stdout and stderr
    ## into separate components.

    outfile <- tempfile("xshell")
    errfile <- tempfile("xshell")
    on.exit(unlink(c(outfile, errfile)))
    status <- system2(command, args, env = env,
                      stdout = outfile, stderr = errfile,
                      stdin = stdin, input = input)
    list(status = status,
         stdout = readLines(outfile, warn = FALSE),
         stderr = readLines(errfile, warn = FALSE))
}

### ** .try_quietly

.try_quietly <-
function(expr)
{
    ## Try to run an expression, suppressing all 'output'.  In case of
    ## failure, stop with the error message and a "traceback" ...

    oop <- options(warn = 1)
    on.exit(options(oop))
    outConn <- file(open = "w+")         # anonymous tempfile
    sink(outConn, type = "output")
    sink(outConn, type = "message")
    yy <- tryCatch(withRestarts(withCallingHandlers(expr, error = {
        function(e) invokeRestart("grmbl", e, sys.calls())
    }),
                                grmbl = function(e, calls) {
                                    n <- length(sys.calls())
                                    ## Chop things off as needed ...
                                    calls <- calls[-seq.int(length.out = n - 1L)]
                                    calls <- rev(calls)[-c(1L, 2L)]
                                    tb <- lapply(calls, deparse)
                                    stop(conditionMessage(e),
                                         "\nCall sequence:\n",
                                         paste(.eval_with_capture(traceback(tb))$output,
                                               collapse = "\n"),
                                         call. = FALSE)
                                }),
                   error = identity,
                   finally = {
                       sink(type = "message")
                       sink(type = "output")
                       close(outConn)
                   })
    if(inherits(yy, "error"))
        stop(yy)
    yy
}

### ** .unpacked_source_repository_apply

.unpacked_source_repository_apply <-
function(dir, fun, ..., verbose = FALSE)
{
    dir <- file_path_as_absolute(dir)

    dfiles <- Sys.glob(file.path(dir, "*", "DESCRIPTION"))

    results <-
        lapply(dirname(dfiles),
               function(dir) {
                   if(verbose)
                       message(sprintf("processing %s", basename(dir)))
                   fun(dir, ...)
               })
    names(results) <- basename(dirname(dfiles))
    results
}

### ** .wrong_args

.wrong_args <-
function(args, msg)
{
    len <- length(args)
    if(!len)
        character()
    else if(len == 1L)
        paste("argument", sQuote(args), msg)
    else
        paste("arguments",
              paste(c(rep.int("", len - 1L), "and "),
                    sQuote(args),
                    c(rep.int(", ", len - 1L), ""),
                    sep = "", collapse = ""),
              msg)
}


### ** pskill

pskill <- function(pid, signal = SIGTERM)
    invisible(.Call(ps_kill, pid, signal))

### ** psnice

psnice <- function(pid = Sys.getpid(), value = NA_integer_)
{
    res <- .Call(ps_priority, pid, value)
    if(is.na(value)) res else invisible(res)
}
### Local variables: ***
### mode: outline-minor ***
### outline-regexp: "### [*]+" ***
### End: ***
#  File src/library/tools/R/xgettext.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/

xgettext <-
function(dir, verbose = FALSE, asCall = TRUE)
{
    dir <- file_path_as_absolute(dir)
    bn <- basename(dir)
    dir <- file.path(dir, "R")
    exts <- .make_file_exts("code")
    R_files <- list_files_with_exts(dir, exts)
    for(d in c("unix", "windows")) {
        OSdir <- file.path(dir, d)
        if(file_test("-d", OSdir))
            R_files <- c(R_files, list_files_with_exts(OSdir, exts))
    }
    if(bn == "base") {
        ## include loader files in R_HOME/share/R
        shdir <- file.path(dir, "../../../../share/R")
        R_files <- c(R_files, list_files_with_exts(shdir, exts))
    }
    out <- vector("list", length = length(R_files))
    names(out) <- R_files

    find_strings <- function(e) {
        find_strings2 <- function(e, suppress) {
            if(is.character(e)) {
                if(!suppress) strings <<- c(strings, e)
            } else if(is.call(e)) {
                if(is.name(e[[1L]])
                   && (as.character(e[[1L]]) %in% c("gettext", "gettextf"))) {
                    domain <- e[["domain"]]
                    suppress <- !is.null(domain) && !is.name(domain) && is.na(domain)
                    if(as.character(e[[1L]]) == "gettextf") {
                        e <- match.call(gettextf, e)
                        e <- e["fmt"] # just look at fmt arg
                    } else if(as.character(e[[1L]]) == "gettext" &&
                              !is.null(names(e))) {
                        e <- e[!(names(e) == "domain")] # remove domain arg
                    }
                }
                for(i in seq_along(e)) find_strings2(e[[i]], suppress)
            }
        }
        if(is.call(e)
           && is.name(e[[1L]])
           && (as.character(e[[1L]])
               %in% c("warning", "stop", "message", "packageStartupMessage",
                      "gettext", "gettextf"))) {
             domain <- e[["domain"]]
             suppress <- !is.null(domain) && !is.name(domain) && is.na(domain)
             ## remove named args
             if(!is.null(names(e)))
                 e <- e[!names(e) %in% c("call.", "immediate.", "domain")]
             if(asCall) {
                 if(!suppress) strings <<- c(strings, as.character(e)[-1L])
             } else {
                 if(as.character(e[[1L]]) == "gettextf") {
                     e <- match.call(gettextf, e)
                     e <- e["fmt"] # just look at fmt arg
                 }
                 for(i in seq_along(e)) find_strings2(e[[i]], suppress)
             }
        } else if(is.recursive(e))
            for(i in seq_along(e)) Recall(e[[i]])
    }

    for(f in R_files) {
        if(verbose) message(gettextf("parsing '%s'", f), domain = NA)
        strings <- character()
        for(e in parse(file = f)) find_strings(e)
        ## strip leading and trailing white space
        strings <- sub("^[ \t\n]*", "", strings)
        strings <- sub("[ \t\n]*$", "", strings)
        out[[f]] <- structure(unique(strings), class="xgettext")
    }

    out[sapply(out, length) > 0L]
}

print.xgettext <-
function(x, ...)
{
    cat(x, sep = "\n")
    invisible(x)
}

print.xngettext <-
function(x, ...)
{
    lapply(x, function(x)
           cat("\nmsgid        = ", x[1L],
               "\nmsgid_plural = ", x[2L],
               "\n", sep = ""))
    invisible(x)
}

xngettext <-
function(dir, verbose = FALSE)
{
    dir <- file_path_as_absolute(dir)
    dir <- file.path(dir, "R")
    exts <- .make_file_exts("code")
    R_files <- list_files_with_exts(dir, exts)
    for(d in c("unix", "windows", "aqua")) {
        OSdir <- file.path(dir, d)
        if(file_test("-d", OSdir))
            R_files <- c(R_files, list_files_with_exts(OSdir, exts))
    }
    out <- vector("list", length = length(R_files))
    names(out) <- R_files

    find_strings <- function(e) {
        if(is.call(e) && is.name(e[[1L]])
           && as.character(e[[1L]]) %in% "ngettext") {
	    e <- match.call(ngettext, e)
            domain <- e[["domain"]]
            suppress <- !is.null(domain) && !is.name(domain) && is.na(domain)
	    if (!suppress &&
                is.character(e[["msg1"]]) && is.character(e[["msg2"]]))
	    	strings <<- c(strings, list(c(msg1 = e[["msg1"]],
	    				      msg2 = e[["msg2"]])))
        } else if(is.recursive(e))
            for(i in seq_along(e)) Recall(e[[i]])
    }

    for(f in R_files) {
        if(verbose) message(gettextf("parsing '%s'", f), domain = NA)
        strings <- list()
        for(e in parse(file = f)) find_strings(e)
        out[[f]] <- structure(strings, class="xngettext")
    }

    out[sapply(out, length) > 0L]
}

xgettext2pot <-
function(dir, potFile, name = "R", version, bugs)
{
    dir <- file_path_as_absolute(dir)
    if(missing(potFile))
        potFile <- paste0("R-", basename(dir), ".pot")
    tmp <- unique(unlist(xgettext(dir, asCall = FALSE)))
    tmp <- tmp[nzchar(tmp)]
    if(length(tmp) > 0L)
	tmp <- shQuote(encodeString(tmp), type="cmd")  # need to quote \n, \t etc
    con <- file(potFile, "wt")
    on.exit(close(con))
    if(missing(version))
        version <- paste(R.version$major, R.version$minor, sep = ".")
    if(missing(bugs)) bugs <- "bugs.r-project.org"
    writeLines(con = con,
               c('msgid ""',
                 'msgstr ""',
                 sprintf('"Project-Id-Version: %s %s\\n"', name, version),
                 sprintf('"Report-Msgid-Bugs-To: %s\\n"', bugs),
                 paste0('"POT-Creation-Date: ',
                        format(Sys.time(), "%Y-%m-%d %H:%M"), # %z is not portable
                        '\\n"'),
                 '"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\\n"',
                 '"Last-Translator: FULL NAME <EMAIL@ADDRESS>\\n"',
                 '"Language-Team: LANGUAGE <LL@li.org>\\n"',
                 '"MIME-Version: 1.0\\n"',
                 '"Content-Type: text/plain; charset=CHARSET\\n"',
                 '"Content-Transfer-Encoding: 8bit\\n"', ''))
    for(e in tmp)
        writeLines(con=con, c('', paste('msgid', e), 'msgstr ""'))
    tmp <- xngettext(dir)
    un <- unique(unlist(tmp, recursive=TRUE))
    for(ee in tmp)
        for(e in ee)
            if(e[1L] %in% un) {
                writeLines(con=con, c('',
                           paste('msgid       ',
                                 shQuote(encodeString(e[1L]), type="cmd")),
                           paste('msgid_plural',
                                 shQuote(encodeString(e[2L]), type="cmd")),
                           'msgstr[0]    ""', 'msgstr[1]    ""')
                           )
                un <- un[-match(e, un)]
            }
}


checkPoFile <- function(f, strictPlural = FALSE)
{
    getfmts <- function(s) .Call(C_getfmts, s)

    lines <- readLines(f, encoding = "bytes")
    i <- 0
    noCformat <- FALSE
    f1_plural <- NULL
    ref <- NA
    fuzzy <- FALSE

    result <- matrix(character(), ncol = 5L, nrow = 0L)
    while (i < length(lines)) {
	i <- i + 1L

	if (grepl("^#,", lines[i], useBytes = TRUE)) {
	    noCformat <- noCformat || grepl("no-c-format", lines[i], useBytes = TRUE)
	    fuzzy <- fuzzy || grepl("fuzzy", lines[i], useBytes = TRUE)
	} else if (grepl("^#:", lines[i], useBytes = TRUE)) {
	    if (!is.na(ref))
		ref <- paste(ref, "etc.")
	    else
		ref <- sub("^#:[[:blank:]]*", "", lines[i])
	} else if (grepl("^msgid ", lines[i], useBytes = TRUE)) {
	    s1 <- sub('^msgid[[:blank:]]+["](.*)["][[:blank:]]*$', "\\1", lines[i])
	    while (grepl('^["]', lines[i+1L], useBytes = TRUE)) {
		i <- i + 1L
		s1 <- paste0(s1, sub('^["](.*)["][[:blank:]]*$', "\\1", lines[i]))
	    }
	    f1 <- tryCatch(getfmts(s1), error = function(e)e)
	    j <- i + 1L

	    if (noCformat || inherits(f1, "error")) {
		noCformat <- FALSE
		next
	    }

	    while (j <= length(lines)) {
		if (grepl("^msgid_plural[[:blank:]]", lines[j], useBytes = TRUE))
		    statement <- "msgid_plural"
		else if (grepl("^msgstr[[:blank:]]", lines[j], useBytes = TRUE))
		    statement <- "msgstr"
		else if (grepl("^msgstr\\[[[:digit:]]+\\][[:blank:]]", lines[j], useBytes = TRUE))
		    statement <- sub("^(msgstr)\\[([[:digit:]]+)\\].*$", "\\1\\\\[\\2\\\\]", lines[j])
		else
		    break

		s2 <- sub( paste0("^", statement, "[[:blank:]]+[\"](.*)[\"][[:blank:]]*$"),
		                 "\\1", lines[j])
		while (grepl('^["]', lines[j+1L], useBytes = TRUE)) {
		    j <- j+1L
		    s2 <- paste0(s2, sub('^["](.*)["][[:blank:]]*$', "\\1", lines[j]))
		}

		if (s1 == "") { # The header
		    encoding <- sub(".*Content-Type:[^\\]*charset=([^\\[:space:]]*)[[:space:]]*\\\\n.*", "\\1", s2)
		    lines <- iconv(lines, encoding, "UTF-8")
		    break
		}

		f2 <- tryCatch(getfmts(s2), error = function(e)e)

		if (statement == "msgid_plural") {
		    if (!strictPlural) {
			f1_plural <- f2
			j <- j+1L
			next
		    }
		}

		if (s2 != "" &&
		     !(identical(f1, f2) || identical(f1_plural, f2))) {
		    location <- paste0(f, ":", j)
		    if (inherits(f2, "error"))
			diff <- conditionMessage(f2)
		    else {
		    	if (length(f1) < length(f2)) {
			    diff <- "too many entries"
			    length(f2) <- length(f1)
		    	} else if (length(f1) > length(f2)) {
			    diff <- "too few entries"
			    length(f1) <- length(f2)
			} else
			    diff <- ""
			diffs <- which(f1 != f2)
			if (length(diffs)) {
			    if (diff != "")
			    	diff <- paste0(diff, ", ")
			    if (length(diffs) > 1)
				diff <- paste(paste0(diff, "differences in entries"),
			                      paste(diffs, collapse = ","))
			    else
				diff <- paste(paste0(diff, "difference in entry"),
				              diffs)
			}
			if (grepl("\u066A", s2, fixed=TRUE))
			    diff <- paste0(diff, ", translation contains arabic percent sign U+066A")
			if (grepl("\uFE6A", s2, fixed=TRUE))
			    diff <- paste0(diff, ", translation contains small percent sign U+FE6A")
			if (grepl("\uFF05", s2, fixed=TRUE))
			    diff <- paste0(diff, ", translation contains wide percent sign U+FF05")
		    }
                    if (!fuzzy)
                        result <- rbind(result, c(location, ref, diff, s1, s2))
		}
		j <- j+1L
	    }
	    i <- j-1L
	    noCformat <- FALSE
	    f1_plural <- NULL
	    ref <- NA
            fuzzy <- FALSE
	}
    }
    structure(result, class = "check_po_files")
}

checkPoFiles <- function(language, dir=".")
{
    files <- list.files(path = dir, pattern = paste0(language, "[.]po$"),
                        full.names = TRUE, recursive = TRUE)
    result <- matrix(character(), ncol = 5L, nrow = 0L)
    for (f in files) {
	errs <- checkPoFile(f, strictPlural = grepl("^R-", basename(f)))
	if (nrow(errs)) result <- rbind(result, errs)
    }
    structure(result, class = "check_po_files")
}

print.check_po_files <- function(x, ...)
{
    if (!nrow(x))
	cat("No errors\n")
    else
	for (i in 1:nrow(x)) {
	    if (is.na(x[i, 2L])) cols <- c(1L, 3:5)
	    else cols <- 1:5
	    cat(x[i, cols], sep = "\n")
	    cat("\n")
	}
}
#  File src/library/tools/R/zzz.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R 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 of the License, 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/

.noGenerics <- TRUE

.onUnload <-
function(libpath)
    library.dynam.unload("tools", libpath)

library.dynam("tools", "tools", .Library)
PS_sigs <- getDLLRegisteredRoutines("tools")[[c(".Call", "ps_sigs")]]

## These are created at install time: the numbers are hard-coded in signals.c
## They happen to be the BSD ones as this started in multicore
SIGHUP <- .Call(PS_sigs, 1L)
SIGINT <- .Call(PS_sigs, 2L)
SIGQUIT <- .Call(PS_sigs, 3L)
SIGKILL <- .Call(PS_sigs, 9L)
SIGTERM <- .Call(PS_sigs, 15L)
SIGSTOP <- .Call(PS_sigs, 17L)
SIGTSTP <- .Call(PS_sigs, 18L)
SIGCONT <- .Call(PS_sigs, 19L)
SIGCHLD <- .Call(PS_sigs, 20L)
SIGUSR1 <- .Call(PS_sigs, 30L)
SIGUSR2 <- .Call(PS_sigs, 31L)

## This calls C code in the package too
latexArgCount <- integer()              # The next line modifies this
latexTable <- makeLatexTable(utf8table)  # FIXME: Should latexTable be hardcoded instead?
rm(PS_sigs)

.onLoad <- function(libname, pkgname) {
    ## see if we can render Unicode bullet: not C locales, nor CJK on Windows.
    if (.Platform$OS.type == "windows") {
	cp <- l10n_info()$codepage
	if (cp > 0 && (cp == 874L || (cp >= 1250L && cp <= 1258L)))
	    Rd2txt_options(itemBullet = "\u2022 ")
    } else if (!is.na(iconv("\u2022", "UTF-8", "")))
	Rd2txt_options(itemBullet = "\u2022 ")
}