#  File src/library/tools/R/makeLazyLoad.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2022 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, dir, use_datalist = TRUE)
{
    if(!missing(package)) { # installed package
        dir <- find.package(package, lib.loc, quiet = TRUE)
        if(!length(dir))
            stop(packageNotFoundError(package, lib.loc, sys.call()))
    } else { # the dir case (source or installed pkgpath)
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        if(!dir.exists(dir))
            stop(gettextf("directory '%s' does not exist", dir), domain = NA)
        dir <- file_path_as_absolute(dir)
        package <- character(0L)
        lib.loc <- NULL
    }
    if(dir.exists(dataDir <- file.path(dir, "data"))) {
        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 {
            if (!length(package)) { # the dir case
                ## data(package=character(0L)) will look in getwd()/data
                owd <- setwd(dir)
                on.exit(setwd(owd))
            }
            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)
            }
        }
    }
}

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))

    ## This can be inefficient if there are many environments,
    ## e.g. from source references (PR18236), but has to be used in
    ## initial bootstrapping since hash tables in the utils package
    ## are not yet available.
    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)
        insert <- function(e) {
            idx <<- idx + 1
            name <- paste0("env::", idx)
            envs <<- c(e, envs)
            enames <<- c(name, enames)
            name
        }
        list(insert = insert, getname = getname)
    }
    ## Use a hash table once utils is fully available.
    if (file.exists(system.file("R", "utils.rdx", package = "utils")) &&
        is.environment(tryCatch(loadNamespace("utils"), error=identity)))
        envtable <- function() {
            idx <- 0
            h <- utils::hashtab()
            getname <- function(e) utils::gethash(h, e)
            insert <- function(e) {
                idx <<- idx + 1
                name <- paste0("env::", idx)
                utils::sethash(h, e, name)
                name
            }
            list(insert = insert, 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)
    if(!getOption("warn")) options(warn = 1L) # ( keep warn=2 !)
    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()
}
