#  File src/library/tools/R/makeLazyLoad.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2019 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
#  https://www.R-project.org/Licenses/

code2LazyLoadDB <-
    function(package, lib.loc = NULL,
             keep.source = getOption("keep.source.pkgs"),
             keep.parse.data = getOption("keep.parse.data.pkgs"),
             compress = TRUE, set.install.dir = NULL)
{
    pkgpath <- find.package(package, lib.loc, quiet = TRUE)
    if(!length(pkgpath))
        stop(packageNotFoundError(package, lib.loc, sys.call()))
    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 = package, lib.loc = lib.loc,
                  keep.source = keep.source, keep.parse.data = keep.parse.data,
                  partial = TRUE))
        makeLazyLoadDB(ns, dbbase, compress = compress,
                       set.install.dir = set.install.dir)
    }
    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, use_datalist = TRUE)
{
    if(is.null(dataDir)) {
        pkgpath <- find.package(package, lib.loc, quiet = TRUE)
        if(!length(pkgpath))
            stop(packageNotFoundError(package, lib.loc, sys.call()))
        dataDir <- file.path(pkgpath, "data")
    } else {
	if(has.pkg <- !missing(package)) ## try with default lib.loc
	    pkgpath <- find.package(package, lib.loc, quiet = TRUE)
	if(!has.pkg || !length(pkgpath)) {
	   ## <FIXME> making assumptions about dataDir (e.g., pkgpath *NOT* from R-forge symlink)
	    pkgpath <- sub("/data$", "", dataDir)
	    ## avoid builddir != srcdir problems -- assume package has been installed
	    ## making use of the fact that utils::data() works with *source* package:
	    lib.loc <- c(dirname(pkgpath), .libPaths())
	    if(!has.pkg)
		package <- basename(pkgpath)
	}
    }
    if(dir.exists(dataDir)) {
        if(file.exists(sv <- file.path(dataDir, "Rdata.rds"))) {
            ans <- readRDS(sv)
        } else if(file.exists(sv <- file.path(dataDir, "datalist"))
                  && use_datalist
                  && !file.info(sv)$isdir) { # package cp4p had a directory
            ## 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) {
                ## This occasionally fails on uninstalled sources,
                ## hence the tryCatch().  And e.g. CHNOSZ gave
                ## messages and cricketr gave warnings.
                tryCatch(suppressMessages(suppressWarnings(utils::data(list = f, package = package, lib.loc = lib.loc, envir = dataEnv))), error = identity)
                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(packageNotFoundError(package, lib.loc, sys.call()))
    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(dir.exists(dataDir)) {
        if(file.exists(file.path(dataDir, "Rdata.rds")) &&
	    file.exists(file.path(dataDir, paste0(package, ".rdx"))) &&
	    file.exists(file.path(dataDir, paste0(package, ".rdb"))) ){
            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, overwrite = TRUE)
                utils::data(list = f, package = package, lib.loc = lib.loc,
                        envir = tmpEnv, overwrite = TRUE)
                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, set.install.dir = NULL)
{
    ## pre-empt any problems with interpretation of 'ascii'
    ascii <- as.logical(ascii)
    if (is.na(ascii)) stop("'ascii' must be TRUE or FALSE", domain = NA)
    ascii <- as.integer(ascii)

    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 <- paste0("env::", idx)
            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 <- paste0(filebase, ".rdx")
    datafile <- paste0(filebase, ".rdb")
    close(file(datafile, "wb")) # truncate to zero
    table <- envtable()
    varenv <- new.env(hash = TRUE)
    envenv <- new.env(hash = TRUE)

    # bindings of names from "lazy" will be serialized independently so that
    # they can be loaded lazily, after the other bindings have already been
    # eagerly loaded

    lazyenvhook <- function(e, bindings, lazy) {
        bnames <- names(bindings)
        lnames <- intersect(bnames, lazy)
        if (length(lnames)) {
            enames <- setdiff(bnames, lazy)
            edata <- list(bindings = bindings[enames],
                          enclos = parent.env(e),
                          attributes = attributes(e),
                          isS4 = isS4(e),
                          locked = environmentIsLocked(e))
            ekey <- lazyLoadDBinsertValue(edata, datafile, ascii,
                          compress, envhook)
            lkeys <- lapply(lnames, function(varname) {
                lazyLoadDBinsertValue(bindings[[varname]], datafile,
                                      ascii, compress, envhook)
            })
            names(lkeys) <- lnames
            list(eagerKey = ekey, lazyKeys = lkeys)
        }
    }

    envhook <- function(e) {
        if (is.environment(e)) {
            name <- table$getname(e)
            if (is.null(name)) {
                name <- table$insert(e)
                bindings <- envlist(e)
                key <- NULL

                if (!is.null(set.install.dir)) {
                    if (inherits(e, "srcfilecopy") &&
                            "filename" %in% names(bindings))
                        bindings[["filename"]] <- set.install.dir

                    if (identical(e, nsinfo) && "path" %in% names(bindings))
                        bindings[["path"]] <- set.install.dir
                }

                if (inherits(e, "srcfile"))
                    key <- lazyenvhook(e, bindings, c("lines", "parseData"))

                if (is.null(key)) {
                    data <- list(bindings = bindings,
                                 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")

    if (!is.null(set.install.dir) && is.environment(from)
            && ".__NAMESPACE__." %in% vars) {
        x <- .Internal(getVarsFromFrame(".__NAMESPACE__.", from, FALSE))
        nsinfo <- x[[1L]]
    } else
        nsinfo <- NULL

    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"),
             keep.parse.data = getOption("keep.parse.data.pkgs"),
             set.install.dir = NULL)
{
    if(!is.logical(compress) && compress %notin% c(2,3))
	stop(gettextf("invalid value for '%s' : %s", "compress",
		      "should be FALSE, TRUE, 2 or 3"), domain = NA)
    options(warn = 1L)
    findpack <- function(package, lib.loc) {
        pkgpath <- find.package(package, lib.loc, quiet = TRUE)
        if(!length(pkgpath))
            stop(packageNotFoundError(package, lib.loc, sys.call()))
        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.size(codeFile) == file.size(loaderFile))
        warning("package seems to be using lazy loading already")
    else {
        code2LazyLoadDB(package, lib.loc = lib.loc,
                        keep.source = keep.source,
                        keep.parse.data = keep.parse.data,
                        compress = compress,
                        set.install.dir = set.install.dir)
        file.copy(loaderFile, codeFile, TRUE)
    }

    invisible()
}
