1#  File src/library/base/R/lazyload.R
2#  Part of the R package, https://www.R-project.org
3#
4#  Copyright (C) 1995-2020 The R Core Team
5#
6#  This program is free software; you can redistribute it and/or modify
7#  it under the terms of the GNU General Public License as published by
8#  the Free Software Foundation; either version 2 of the License, or
9#  (at your option) any later version.
10#
11#  This program is distributed in the hope that it will be useful,
12#  but WITHOUT ANY WARRANTY; without even the implied warranty of
13#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14#  GNU General Public License for more details.
15#
16#  A copy of the GNU General Public License is available at
17#  https://www.R-project.org/Licenses/
18
19## This code should be kept in step with code in ../baseloader.R
20##
21## This code has been factored in a somewhat peculiar way to allow the
22## lazy load data base mechanism to be used for storing processed .Rd
23## files. This isn't quite right as the .Rd use only uses the data
24## base, not the lazy load part, but for now it will do. LT
25
26lazyLoadDBexec <- function(filebase, fun, filter)
27{
28    ##
29    ## bootstrapping definitions so we can load base
30    ## - not that this version is actually used to load base (but the ../baseloader.R  one is!)
31    ##
32    glue <- function (..., sep = " ", collapse = NULL)
33##      .Internal(paste(list(...), sep, collapse, TRUE))# recycle0=TRUE
34        .Internal(paste(list(...), sep, collapse, FALSE))
35    readRDS <- function (file) {
36        halt <- function (message) .Internal(stop(TRUE, message))
37        gzfile <- function (description, open)
38            .Internal(gzfile(description, open, "", 6))
39        close <- function (con) .Internal(close(con, "rw"))
40        if (! is.character(file)) halt("bad file name")
41        con <- gzfile(file, "rb")
42        on.exit(close(con))
43        .Internal(unserializeFromConn(con, baseenv()))
44    }
45    `parent.env<-` <-
46        function (env, value) .Internal(`parent.env<-`(env, value))
47    existsInFrame <- function (x, env) .Internal(exists(x, env, "any", FALSE))
48    list2env <- function (x, envir) .Internal(list2env(x, envir))
49    environment <- function () .Internal(environment(NULL))
50    mkenv <- function() .Internal(new.env(TRUE, baseenv(), 29L))
51
52    ##
53    ## main body
54    ##
55    mapfile  <- glue(filebase, "rdx", sep = ".")
56    datafile <- glue(filebase, "rdb", sep = ".")
57    env <- mkenv()
58    map <- readRDS(mapfile)
59    vars <- names(map$variables)
60    compressed <- map$compressed
61    list2env(map$references, env)
62    envenv <- mkenv()
63    envhook <- function(n) {
64        if (existsInFrame(n, envenv))
65            envenv[[n]]
66        else {
67            e <- mkenv()
68            envenv[[n]] <- e           # MUST do this immediately
69            key <- env[[n]]
70            ekey <- if (is.list(key)) key$eagerKey else key
71            data <- lazyLoadDBfetch(ekey, datafile, compressed, envhook)
72            ## comment from r41494
73            ## modified the loading of old environments, so that those
74            ## serialized with parent.env NULL are loaded with the
75            ## parent.env=emptyenv(); and yes an alternative would have been
76            ## baseenv(), but that was seldom the intention of folks that
77            ## set the environment to NULL.
78            parent.env(e) <- if(!is.null(data$enclos)) data$enclos else emptyenv()
79            list2env(data$bindings, e)
80            if (! is.null(data$attributes))
81                attributes(e) <- data$attributes
82            if (! is.null(data$isS4) && data$isS4)
83                .Internal(setS4Object(e, TRUE, TRUE))
84
85            ## lazily loaded bindings (used e.g. for parseData and lines from
86            ## source references)
87            if (is.list(key)) {
88                expr <- quote(lazyLoadDBfetch(KEY, datafile, compressed, envhook))
89                .Internal(makeLazy(names(key$lazyKeys), key$lazyKeys, expr,
90                    parent.env(environment()), e))
91            }
92            if (! is.null(data$locked) && data$locked)
93                .Internal(lockEnvironment(e, FALSE))
94            e
95        }
96    }
97    if (!missing(filter)) {
98        use <- filter(vars)
99        vars <- vars[use]
100        vals <- map$variables[use]
101        use <- NULL
102    } else
103        vals <-  map$variables
104
105    ## This may use vals.
106    res <- fun(environment())
107
108    ## reduce memory use
109    map <- NULL
110    vars <- NULL
111    vals <- NULL
112    rvars <- NULL
113    mapfile <- NULL
114    readRDS <- NULL
115
116    res
117}
118
119lazyLoad <- function(filebase, envir = parent.frame(), filter)
120{
121    fun <- function(db) {
122        vals <- db$vals
123        vars <- db$vars
124        expr <- quote(lazyLoadDBfetch(key, datafile, compressed, envhook))
125        .Internal(makeLazy(vars, vals, expr, db, envir))
126    }
127    lazyLoadDBexec(filebase, fun, filter)
128}
129