1
2load_client_lib <- function(sofile = NULL, pxdir = NULL) {
3  ext <- .Platform$dynlib.ext
4  sofile_in_processx <- function() {
5    arch <- .Platform$r_arch
6    if (!is.null(pxdir)) {
7      sofile <- file.path(pxdir, "libs", arch, paste0("client", ext))
8      if (file.exists(sofile)) return(sofile)
9    }
10
11    sofile <- system.file(
12      "libs", arch, paste0("client", ext),
13      package = "processx")
14    if (sofile != "" && file.exists(sofile)) return(sofile)
15
16    # Try this as well, this is for devtools/pkgload
17    sofile <- system.file(
18      "src", paste0("client", ext),
19      package = "processx")
20    if (sofile != "" && file.exists(sofile)) return(sofile)
21
22    # stop() here and not throw(), because this function should be standalone
23    stop("Cannot find client file")
24  }
25
26  if (is.null(sofile)) {
27    sofile <- sofile_in_processx()
28    lib <- dyn.load(sofile)
29  } else {
30    # This is the usual case, first we try loading it from the
31    # temporary directory. If that fails (e.g. noexec), then
32    # from processx. We saved the location of processx when we
33    # loaded callr, just in case the used changes the lib path.
34    lib <- tryCatch(dyn.load(sofile), error = function(err) err)
35    if (inherits(lib, "error")) {
36      sofile <- sofile_in_processx()
37      tryCatch(
38        lib <- dyn.load(sofile),
39	error = function(err2) {
40	  err2$message <- err2$message <- paste0(" after ", lib$message)
41	  stop(err2)
42	}
43      )
44    }
45  }
46
47  # cleanup if setup fails
48  on.exit(dyn.unload(sofile))
49
50  sym_encode <- getNativeSymbolInfo("processx_base64_encode", lib)
51  sym_decode <- getNativeSymbolInfo("processx_base64_decode", lib)
52  sym_disinh <- getNativeSymbolInfo("processx_disable_inheritance", lib)
53  sym_write  <- getNativeSymbolInfo("processx_write", lib)
54  sym_setout <- getNativeSymbolInfo("processx_set_stdout", lib)
55  sym_seterr <- getNativeSymbolInfo("processx_set_stderr", lib)
56  sym_setoutf <- getNativeSymbolInfo("processx_set_stdout_to_file", lib)
57  sym_seterrf <- getNativeSymbolInfo("processx_set_stderr_to_file", lib)
58
59  env <- new.env(parent = emptyenv())
60  env$.path <- sofile
61
62  mycall <- .Call
63
64  env$base64_encode <- function(x) rawToChar(mycall(sym_encode, x))
65  env$base64_decode <- function(x) {
66    if (is.character(x)) {
67      x <- charToRaw(paste(gsub("\\s+", "", x), collapse = ""))
68    }
69    mycall(sym_decode, x)
70  }
71
72  env$disable_fd_inheritance <- function() mycall(sym_disinh)
73
74  env$write_fd <- function(fd, data) {
75    if (is.character(data)) data <- charToRaw(paste0(data, collapse = ""))
76    len <- length(data)
77    repeat {
78      written <- mycall(sym_write, fd, data)
79      len <- len - written
80      if (len == 0) break
81      if (written) data <- data[-(1:written)]
82      Sys.sleep(.1)
83    }
84  }
85
86  env$set_stdout <- function(fd, drop = TRUE) {
87    mycall(sym_setout, as.integer(fd), as.logical(drop))
88  }
89
90  env$set_stderr <- function(fd, drop = TRUE) {
91    mycall(sym_seterr, as.integer(fd), as.logical(drop))
92  }
93
94  env$set_stdout_file <- function(path) {
95    mycall(sym_setoutf, as.character(path)[1])
96  }
97
98  env$set_stderr_file <- function(path) {
99    mycall(sym_seterrf, as.character(path)[1])
100  }
101
102  env$.finalize <- function() {
103    dyn.unload(env$.path)
104    rm(list = ls(env, all.names = TRUE), envir = env)
105  }
106
107  penv <- environment()
108  parent.env(penv) <- baseenv()
109
110  reg.finalizer(
111    env,
112    function(e) if (".finalize" %in% names(e)) e$.finalize(),
113    onexit = TRUE)
114
115  ## Clear the cleanup method
116  on.exit(NULL)
117  env
118}
119