/
cache.R
155 lines (129 loc) · 4.35 KB
/
cache.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
#' Set up stdout & stderr cache files for `r_bg` process
#'
#' @param path Path to local repository
#' @return Vector of two strings holding respective local paths to `stdout` and
#' `stderr` files for `r_bg` process controlling the main \link{pkgcheck}
#' function when executed in background mode.
#'
#' @note These files are needed for the \pkg{callr} `r_bg` process which
#' controls the main \link{pkgcheck}. The `stdout` and `stderr` pipes from the
#' process are stored in the cache directory so they can be inspected via their
#' own distinct endpoint calls.
#' @family extra
#' @export
#' @examples
#' \dontrun{
#' logfiles <- logfiles_namnes ("/path/to/my/package")
#' print (logfiles)
#' }
logfile_names <- function (path) {
temp_dir <- fs::path (Sys.getenv ("PKGCHECK_CACHE_DIR"), "templogs")
if (!dir.exists (temp_dir)) {
dir.create (temp_dir, recursive = TRUE)
}
pkg_hash <- current_hash (path)
pkg_hash_fmt <- paste0 (pkg_hash, collapse = "_")
sout <- fs::path (temp_dir, paste0 (pkg_hash_fmt, "_stdout"))
serr <- fs::path (temp_dir, paste0 (pkg_hash_fmt, "_stderr"))
otherlogs <- list.files (
temp_dir,
pattern = pkg_hash [1],
full.names = TRUE
)
otherlogs <- otherlogs [which (!grepl (pkg_hash [2], otherlogs))]
if (length (otherlogs) > 0) {
file.remove (otherlogs)
}
return (list (stdout = sout, stderr = serr))
}
#' Get hash of last git commit
#'
#' @param path Path to local source directory
#' @return Vector of 2 values: (package name, hash)
#' @noRd
current_hash <- function (path) {
if (!fs::file_exists (fs::path (path, "DESCRIPTION"))) {
stop ("path [", path, "] does not appear to be an R package")
}
desc <- data.frame (read.dcf (file.path (path, "DESCRIPTION")),
stringsAsFactors = FALSE
)
pkg <- desc$Package
if (repo_is_git (path)) {
g <- gert::git_info (path)
hash <- substring (g$commit, 1, 8)
} else { # not a git repo, so use mtime as hash
flist <- list.files (path, recursive = TRUE, full.names = TRUE)
mt <- file.info (flist)$mtime
if (any (!is.na (mt))) {
mt <- max (mt, na.rm = TRUE)
} else {
mt <- ""
}
hash <- gsub ("\\s+", "-", paste0 (mt))
}
c (pkg, hash)
}
cache_pkgcheck_component <- function (path,
use_cache,
renv_activated,
what = "goodpractice") {
what <- match.arg (what, c ("goodpractice", "pkgstats"))
dir_name <- ifelse (
what == "goodpractice",
"gp_reports",
"pkgstats_results"
)
this_fn <- ifelse (
what == "goodpractice",
goodpractice::goodpractice,
pkgstats::pkgstats
)
pkg_hash <- current_hash (path)
fname <- paste0 (pkg_hash [1], "_", pkg_hash [2])
cache_dir <- file.path (
Sys.getenv ("PKGCHECK_CACHE_DIR"),
dir_name
)
if (!dir.exists (cache_dir)) {
dir.create (cache_dir, recursive = TRUE)
}
cache_file <- fs::path (cache_dir, fname)
# rm old components:
flist <- list.files (cache_dir,
pattern = paste0 (
pkg_hash [1], # name of package
"\\_"
),
full.names = TRUE
)
flist <- flist [which (!grepl (fname, flist))]
if (length (flist) > 0) {
chk <- file.remove (flist)
}
if (fs::file_exists (cache_file) & use_cache) {
out <- readRDS (cache_file)
} else {
# this envvar is for goodpractice, but no harm setting for other
# components too
Sys.setenv ("_R_CHECK_FORCE_SUGGESTS_" = FALSE)
if (renv_activated) {
renv_deactivate (path) # in R/info-renv.R
message (
"'renv' has been de-activated; to reactivate, run ",
"`renv::activate()` in your project directory after ",
"`pkgcheck` has finished"
)
}
out <- suppressWarnings (do.call (this_fn, list (path)))
Sys.unsetenv ("_R_CHECK_FORCE_SUGGESTS_")
# writing to cache_dir fails on some GHA windows machines.
if (dir.exists (cache_dir)) {
chk <- tryCatch (
saveRDS (out, cache_file),
error = function (e) NULL
)
}
}
return (out)
}