@@ -48,230 +48,3 @@ arch_from_platform <- function(platform, na = TRUE) {
4848
4949 arch
5050}
51-
52- # The rest is from pkgcache
53-
54- # ' Current R platform
55- # '
56- # ' `current_r_platform()` detects the platform of the current R version.
57- # '
58- # ' It returns a string of the form `cpu-vendor-os-abi`, a target triplet,
59- # ' see some examples below. On Linux it also includes the distribution
60- # ' name and version and part of the ABI.
61- # '
62- # ' Examples:
63- # ' - `x86_64-apple-darwin17.0`: macOS High Sierra.
64- # ' - `aarch64-apple-darwin20`: macOS Big Sur on arm64.
65- # ' - `x86_64-w64-mingw32`: 64 bit Windows.
66- # ' - `i386-w64-mingw32`: 32 bit Windows.
67- # ' - `i386+x86_64-w64-mingw32`: 64 bit + 32 bit Windows.
68- # ' - `i386-pc-solaris2.10`: 32 bit Solaris. (Some broken 64 Solaris
69- # ' builds might have the same platform string, unfortunately.)
70- # ' - `x86_64-pc-linux-gnu-debian-10`: Debian Linux 10 on x86_64.
71- # ' - `x86_64-pc-linux-musl-alpine-3.14.1`: Alpine Linux.
72- # ' - `x86_64-pc-linux-gnu-unknown`: Unknown Linux Distribution on x86_64.
73- # ' - `s390x-ibm-linux-gnu-ubuntu-20.04`: Ubuntu Linux 20.04 on S390x.
74- # ' - `amd64-portbld-freebsd12.1`: FreeBSD 12.1 on x86_64.
75- # '
76- # ' @export
77- # ' @examples
78- # ' current_r_platform()
79-
80- current_r_platform <- function () {
81- current_r_platform_data()$ platform
82- }
83-
84- current_r_platform_data <- function () {
85- forced <- forced_platform()
86- if (! is.null(forced )) {
87- platform <- parse_platform(forced )
88- } else {
89- raw <- get_platform(forced = FALSE )
90- platform <- parse_platform(raw )
91- if (platform $ os == " linux" || substr(platform $ os , 1 , 6 ) == " linux-"
92- platform <- current_r_platform_data_linux(platform )
93- }
94- }
95-
96- platform $ platform <- apply(platform , 1 , paste , collapse = " -"
97- platform
98- }
99-
100- valid_platform_string <- function (x ) {
101- grepl(" ^[^-].*[-][^-].*[-][^-].*$" x )
102- }
103-
104- forced_platform <- function () {
105- opt <- getOption(" pkg.current_platform"
106- if (! is.null(opt )) {
107- if (! is_string(opt )) {
108- stop(" The `pkg.current_platform` option must be a string scalar."
109- }
110- if (! valid_platform_string(opt )) {
111- stop(
112- " The pkg.current_platform` option must be a valid platform "
113- " triple: `cpu-vendor-os`. \" "
114- opt ,
115- " \" is not."
116- )
117- }
118- return (opt )
119- }
120- env <- Sys.getenv(" PKG_CURRENT_PLATFORM"
121- if (env != " "
122- if (is.na(env ) || ! valid_platform_string(env )) {
123- stop(
124- " The `PKG_CURRENT_PLATFORM` environment variable must be a valid "
125- " platform triple: \" cpu-vendor-os\" . \" "
126- env ,
127- " \" is not."
128- )
129- }
130- return (env )
131- }
132-
133- NULL
134- }
135-
136- get_platform <- function (forced = TRUE ) {
137- (if (forced ) forced_platform()) %|| % R.version $ platform
138- }
139-
140- default_platforms <- function () {
141- unique(c(current_r_platform(), " source"
142- }
143-
144- parse_platform <- function (x ) {
145- # Allow for missing cpu and vendor on Linux
146- if (startsWith(x , " linux-"
147- x <- paste0(" x86_64-unknown-" x )
148- }
149-
150- pcs <- strsplit(x , " -" fixed = TRUE )
151- plt <- data.frame (
152- stringsAsFactors = FALSE ,
153- cpu = vcapply(pcs , " [" 1 ),
154- vendor = vcapply(pcs , " [" 2 ),
155- os = vcapply(pcs , function (y ) {
156- if (length(y ) < 3 ) NA_character_ else paste(y [- (1 : 2 )], collapse = " -"
157- })
158- )
159- linuxos <- re_match(plt $ os , re_linux_platform())
160- islinux <- ! is.na(linuxos $ .match )
161- if (any(islinux )) {
162- plt $ os [islinux ] <- linuxos $ os [islinux ]
163- linuxos $ distribution [linuxos $ distribution == " " <- NA_character_
164- linuxos $ release [linuxos $ release == " " <- NA_character_
165- plt <- cbind(plt , linuxos [, c(" distribution" " release"
166- }
167- plt
168- }
169-
170- re_linux_platform <- function () {
171- paste0(
172- " ^"
173- " (?P<os>linux(?:-gnu|-musl|-uclibc|-dietlibc)?)?"
174- " (?:(?:-)(?P<distribution>[^-]+))?"
175- " (?:(?:-)(?P<release>.+))?"
176- " $"
177- )
178- }
179-
180- current_r_platform_data_linux <- function (raw , etc = " /etc"
181- os <- tryCatch(
182- suppressWarnings(readLines(file.path(etc , " os-release"
183- error = function (e ) NULL
184- )
185- rh <- tryCatch(
186- suppressWarnings(readLines(file.path(etc , " redhat-release"
187- error = function (e ) NULL
188- )
189-
190- cbind(
191- raw [, setdiff(names(raw ), c(" distribution" " release" drop = FALSE ],
192- parse_linux_platform_info(os , rh )
193- )
194- }
195-
196- unknown_dist <- function () {
197- data.frame (
198- stringsAsFactors = FALSE ,
199- distribution = " unknown"
200- )
201- }
202-
203- parse_linux_platform_info <- function (
204- os_release = NULL ,
205- redhat_release = NULL
206- ) {
207- if (
208- is.null(os_release ) &&
209- is.null(redhat_release )
210- ) {
211- unknown_dist()
212- } else if (! is.null(os_release )) {
213- parse_os_release(os_release )
214- } else {
215- parse_redhat_release(redhat_release )
216- }
217- }
218-
219- is_quoted <- function (x ) {
220- l <- nchar(x )
221- l > = 2 &&
222- substr(x , 1 , 1 ) %in% c(" '" ' "' &&
223- substr(x , 1 , 1 ) == substr(x , l , l )
224- }
225-
226- remove_quotes <- function (x ) {
227- l <- nchar(x )
228- if (l < 2 ) {
229- x
230- } else {
231- substr(x , 2 , l - 1 )
232- }
233- }
234-
235- parse_os_release <- function (lines ) {
236- id <- grep(" ^ID=" lines , value = TRUE )[1 ]
237- if (is.na(id )) return (unknown_dist())
238- id <- trimws(sub(" ^ID=(.*)$" " \\ 1" id , perl = TRUE ))
239- if (is_quoted(id )) id <- remove_quotes(id )
240-
241- ver <- grep(" ^VERSION_ID=" lines , value = TRUE )[1 ]
242- if (! is.na(ver )) {
243- ver <- trimws(sub(" VERSION_ID=(.*)$" " \\ 1" ver , perl = TRUE ))
244- if (is_quoted(ver )) ver <- remove_quotes(ver )
245- }
246-
247- out <- data.frame (
248- stringsAsFactors = FALSE ,
249- distribution = id
250- )
251- if (! is.na(ver )) out $ release <- ver
252-
253- if (is.na(ver ) && id == " debian"
254- pn <- grep(" ^PRETTY_NAME=" lines , value = TRUE )[1 ]
255- if (! is.na(pn ) && grepl(" /sid\" ?$" pn )) {
256- out $ release <- " unstable"
257- }
258- }
259-
260- out
261- }
262-
263- parse_redhat_release <- function (lines ) {
264- pcs <- strsplit(lines [1 ], " " fixed = TRUE )[[1 ]]
265- id <- tolower(pcs [1 ])
266- if (id == " " || is.na(id )) return (unknown_dist())
267-
268- wver <- grepl(" ^[-\\ .0-9]+$" pcs )
269-
270- out <- data.frame (
271- stringsAsFactors = FALSE ,
272- distribution = id
273- )
274- if (any(wver )) out $ release <- pcs [wver ][1 ]
275-
276- out
277- }
0 commit comments