@@ -24,20 +24,24 @@ symbol_crs <- function () {
2424# ' @noRd
2525get_github_user <- function () {
2626
27- gh_tok <- gitcreds :: gitcreds_get ()$ password
27+ gh_tok <- get_gh_token ()
2828
2929 # Check corresponding user name:
3030 u <- " https://api.github.com/user"
31- h <- httr :: add_headers (Authorization = paste (" Bearer" gh_tok , sep = " "
32- x <- httr :: content (httr :: GET (u , h ), " text"
33-
34- # Then extract user:
35- x <- strsplit (x , " \\ n" 1 ]]
36- login <- grep (" \\\" login\\\"\\ :" x , value = TRUE )
37- if (length (login ) > 0L ) {
38- login <- gsub (" \\\" |,$" " " login , " \\ :\\ s+" 1 ]] [2 ])
39- } else {
40- login <- " "
31+ req <- httr2 :: request (u )
32+ req <- httr2 :: req_headers (
33+ req ,
34+ " Authorization" = paste0 (" Bearer " gh_tok ),
35+ " Content-Type" = " application/json"
36+ )
37+
38+ resp <- httr2 :: req_perform (req )
39+ httr2 :: resp_check_status (resp )
40+
41+ x <- httr2 :: resp_body_json (resp )
42+ login <- " "
43+ if (" login" %in% names (x )) {
44+ login <- x $ login
4145 }
4246
4347 return (login )
@@ -117,79 +121,4 @@ get_subdir_from_url <- function (repourl) {
117121 return (subdir )
118122}
119123
120- # ' Bob Rudis's URL checker function
121- # '
122- # ' This is used here to check the URLs in the `check_issue_template` function.
123- # '
124- # ' @param x a single URL
125- # ' @param non_2xx_return_value what to do if the site exists but the HTTP status
126- # ' code is not in the `2xx` range. Default is to return `FALSE`.
127- # ' @param quiet if not `FALSE`, then every time the `non_2xx_return_value`
128- # ' condition arises a warning message will be displayed. Default is `FALSE`.
129- # ' @param ... other params (`timeout()` would be a good one) passed directly to
130- # ' `httr::HEAD()` and/or `httr::GET()`
131- # ' @return 'TRUE' is 'x' is a valid URL.
132- # '
133- # ' @note
134- # ' https://stackoverflow.com/questions/52911812/check-if-url-exists-in-r
135- # ' @noRd
136- url_exists <- function (x , non_2xx_return_value = FALSE , quiet = FALSE , ... ) {
137-
138- # you don't need thse two functions if you're already using `purrr`
139- # but `purrr` is a heavyweight compiled pacakge that introduces
140- # many other "tidyverse" dependencies and this doesnt.
141-
142- capture_error <- function (code , otherwise = NULL , quiet = TRUE ) {
143- tryCatch (
144- list (result = code , error = NULL ),
145- error = function (e ) {
146- if (! quiet ) {
147- message (" Error: " e $ message )
148- }
149-
150- list (result = otherwise , error = e )
151- },
152- interrupt = function (e ) {
153- stop (" Terminated by user" call. = FALSE )
154- }
155- )
156- }
157-
158- safely <- function (.f , otherwise = NULL , quiet = TRUE ) {
159- function (... ) capture_error (.f (... ), otherwise , quiet )
160- }
161-
162- sHEAD <- safely (httr :: HEAD ) # nolint
163- sGET <- safely (httr :: GET ) # nolint
164-
165- # Try HEAD first since it's lightweight
166- res <- sHEAD (x , ... )
167-
168- if (is.null (res $ result ) ||
169- ((httr :: status_code (res $ result ) %/% 200 ) != 1 )) {
170-
171- res <- sGET (x , ... )
172-
173- if (is.null (res $ result )) {
174- return (FALSE )
175- } # or whatever you want to return on "hard" errors
176-
177- if (((httr :: status_code (res $ result ) %/% 200 ) != 1 )) {
178- if (! quiet ) {
179- warning (paste0 (
180- " Requests for ["
181- x ,
182- " ] responded but without an HTTP status "
183- " code in the 200-299 range"
184- ))
185- }
186- return (non_2xx_return_value )
187- }
188-
189- return (TRUE )
190-
191- } else {
192- return (TRUE )
193- }
194-
195- }
124+ url_exists <- getFromNamespace (" url_exists" " pkgcheck"
0 commit comments