1
2chk <- function(msg, check) {
3  if (check) TRUE else msg
4}
5
6chks <- function(..., x, warn) {
7  results <- list(...)
8  results <- unlist(setdiff(results, TRUE))
9  results <- if (length(results) == 0) TRUE else results
10
11  if (! identical(results, TRUE) && warn) {
12    warning(
13      call. = FALSE,
14      "'", x$key, "'",
15      paste0(
16        if (length(results) == 1) " " else  "\n    * ",
17        strwrap(results, indent = 0, exdent = 6)
18      )
19    )
20  }
21
22  results
23}
24
25
26#' Syntactical check of a DESCRIPTION field
27#'
28#' @param x The field.
29#' @param warn Whether to generate a warning if the syntax check fails.
30#' @param ... Additional arguments, they might be used in the future.
31#' @return \code{TRUE} if the field is syntactically correct,
32#'   otherwise a character vector, containing one or multiple
33#'   error messages.
34#'
35#' @export
36
37check_field <- function(x, warn = FALSE, ...)
38  UseMethod("check_field")
39
40#' @export
41#' @method check_field DescriptionField
42
43check_field.DescriptionField <- function(x, warn = FALSE, ...) TRUE
44
45##' @export
46##' @method check_field DescriptionPackage
47
48check_field.DescriptionPackage <- function(x, warn = FALSE, R = FALSE, ...) {
49
50  ## In Depends, we can depend on certain 'R' versions
51  if (R && x$value == "R") return(TRUE)
52
53  chks(
54    x = x, warn = warn,
55    chk("must only contain ASCII letters, numbers, dots",
56        grepl("^[a-zA-Z0-9\\.]*$", x$value)),
57    chk("must be at least two characters long",
58        nchar(x$value) >= 2),
59    chk("must start with a letter",
60        grepl("^[a-zA-Z]", x$value)),
61    chk("must not end with a dot",
62        !grepl("\\.$", x$value))
63  )
64}
65
66valid_packagename_regexp <- "[[:alpha:]][[:alnum:].]*[[:alnum:]]"
67valid_version_regexp <- "[0-9]+[-\\.][0-9]+([-\\.][0-9]+)*"
68valid_package_archive_name <- paste0(
69  "^",
70  valid_packagename_regexp,
71  "_",
72  valid_version_regexp,
73  "(.*)?",
74  "(\\.tar\\.gz|\\.tgz|\\.zip)",
75  "$"
76)
77
78##' @export
79##' @method check_field DescriptionVersion
80
81check_field.DescriptionVersion <- function(x, warn = FALSE, ...) {
82
83  chks(
84    x = x, warn = warn,
85    chk(paste("must be a sequence of at least two (usually three)",
86              " non-negative integers separated by a single dot or dash",
87              " character"),
88        grepl(paste0("^", valid_version_regexp, "$"), x$value))
89  )
90}
91
92## TODO: It also must be a license R CMD check recognizes
93##
94##' @export
95##' @method check_field DescriptionLicense
96
97check_field.DescriptionLicense <- function(x, warn = FALSE, ...) {
98
99  chks(
100    x = x, warn = warn,
101    chk("must contain only ASCII characters",
102        is_ascii(x$value)),
103    chk("must not be empty",
104        str_trim(x$value) != "")
105  )
106}
107
108##' @export
109##' @method check_field DescriptionDescription
110
111check_field.DescriptionDescription <- function(x, warn = FALSE, ...) {
112
113  chks(
114    x = x, warn = warn,
115    chk("must not be empty",
116        str_trim(x$value) != ""),
117    chk("must contain one or more complete sentences",
118        grepl("[.!?]['\")]?$", str_trim(x$value))),
119    chk("must not start with 'The package', 'This Package, 'A package'",
120        !grepl("^(The|This|A|In this|In the) package", x$value)),
121    chk("must start with a capital letter",
122        grepl("^['\"]?[[:upper:]]", x$value))
123  )
124}
125
126##' @export
127##' @method check_field DescriptionTitle
128
129check_field.DescriptionTitle <- function(x, warn = FALSE, ...) {
130
131  chks(
132    x = x, warn = warn,
133    chk("must not be empty",
134         str_trim(x$value) != ""),
135    chk("must not end with a period",
136        !grepl("[.]$", str_trim(x$value)) ||
137        grepl("[[:space:]][.][.][.]|et[[:space:]]al[.]", str_trim(x$value)))
138  )
139}
140
141##' @export
142##' @method check_field DescriptionMaintainer
143
144check_field.DescriptionMaintainer <- function(x, warn = FALSE, ...) {
145
146  re_maint <- paste0(
147    "^[[:space:]]*(.*<",
148    RFC_2822_email_regexp,
149    ">|ORPHANED)[[:space:]]*$"
150  )
151
152  chks(
153    x = x, warn = warn,
154    chk("must not be empty",
155        str_trim(x$value) != ""),
156    chk("must contain an email address",
157        grepl(re_maint, x$value))
158  )
159}
160
161## TODO
162##' @export
163##' @method check_field DescriptionAuthorsAtR
164
165check_field.DescriptionAuthorsAtR <- function(x, warn = FALSE, ...) {
166  TRUE
167}
168
169##' @export
170##' @method check_field DescriptionDependencyList
171
172check_field.DescriptionDependencyList <- function(x, warn = FALSE, ...) {
173
174  deps <- parse_deps(x$key, x$value)
175
176  is_package_list <- function(xx) {
177    p <- lapply(xx, function(pc)
178      check_field.DescriptionPackage(
179        list(key = "Package", value = pc),
180        R = x$key[1] == "Depends"
181      )
182    )
183    all_true(p)
184  }
185
186  is_version_req <- function(x) {
187
188    x <- str_trim(x)
189    if (x == "*") return(TRUE)
190
191    re <- paste0(
192      "^(<=|>=|<|>|==|!=)\\s*",
193      valid_version_regexp,
194      "$"
195    )
196    grepl(re, x)
197  }
198
199  is_version_req_list <- function(x) {
200    all_true(vapply(x, is_version_req, TRUE))
201  }
202
203  chks(
204    x = x, warn = warn,
205    chk("must contain valid package names",
206        is_package_list(deps$package)),
207    chk("must contain valid version requirements",
208        is_version_req_list(deps$version))
209  )
210}
211
212##' @export
213##' @method check_field DescriptionRemotes
214
215check_field.DescriptionRemotes <- function(x, warn = FALSE, ...) {
216
217  is_remote <- function(x) {
218    xx <- str_trim(strsplit(x, ",", fixed = TRUE)[[1]])
219    p <- grepl("^[^[:space:]]+$", xx)
220    all_true(p)
221  }
222
223  chks(
224    x = x, warn = warn,
225    chk("must be a comma separated list of remotes",
226        is_remote(x$value))
227  )
228}
229
230##' @export
231##' @method check_field DescriptionPackageList
232
233check_field.DescriptionPackageList <- function(x, warn = FALSE, ...) {
234
235  is_package_list <- function(x) {
236    xx <- str_trim(strsplit(x, ",", fixed = TRUE)[[1]])
237    p <- lapply(xx, function(pc)
238      check_field.DescriptionPackage(list(key = "Package", value = pc)))
239    all_true(p)
240  }
241
242  chks(
243    x = x, warn = warn,
244    chk("must be a comma separated list of package names",
245        is_package_list(x$value))
246  )
247}
248
249##' @export
250##' @method check_field DescriptionRepoList
251
252check_field.DescriptionRepoList <- function(x, warn = FALSE, ...) {
253
254  chks(
255    x = x, warn = warn,
256    chk("must be a comma separated list repository URLs",
257        is_url_list(x$value))
258  )
259}
260
261##' @export
262##' @method check_field DescriptionURL
263
264check_field.DescriptionURL <- function(x, warn = FALSE, ...) {
265
266  chks(
267    x = x, warn = warn,
268    chk("must be a http, https or ftp URL",
269        is_url(x$value))
270  )
271}
272
273##' @export
274##' @method check_field DescriptionURLList
275
276check_field.DescriptionURLList <- function(x, warn = FALSE, ...) {
277
278  chks(
279    x = x, warn = warn,
280    chk("must be a comma separated list of http, https or ftp URLs",
281        is_url_list(x$value))
282  )
283}
284
285##' @export
286##' @method check_field DescriptionPriority
287
288check_field.DescriptionPriority <- function(x, warn = FALSE, ...) {
289
290  chks(
291    x = x, warn = warn,
292    chk("must be one of 'base', 'recommended' or 'defunct-base'",
293        str_trim(x$value) %in% c("base", "recommended", "defunct-base"))
294  )
295}
296
297##' @export
298##' @method check_field DescriptionCollate
299
300check_field.DescriptionCollate <- function(x, warn = FALSE, ...) {
301
302  coll <- tolower(parse_collate(x$value))
303
304  chks(
305    x = x, warn = warn,
306    chk("must contain a list of .R files",
307        all(grepl("[.]r$", coll)))
308  )
309}
310
311##' @export
312##' @method check_field DescriptionLogical
313
314check_field.DescriptionLogical <- function(x, warn = FALSE, ...) {
315
316  chks(
317    x = x, warn = warn,
318    chk("must be one of 'true', 'false', 'yes' or 'no' (case insensitive)",
319        str_trim(tolower(x$value)) %in% c("true", "false", "yes", "no"))
320  )
321}
322
323##' @export
324##' @method check_field DescriptionEncoding
325
326check_field.DescriptionEncoding <- function(x, warn = FALSE, ...) {
327
328  chks(
329    x = x, warn = warn,
330    chk("must be one of 'latin1', 'latin2' and 'UTF-8'",
331        x$value %in% c("latin1", "latin2", "UTF-8"))
332  )
333}
334
335##' @export
336##' @method check_field DescriptionOSType
337
338check_field.DescriptionOSType <- function(x, warn = FALSE, ...) {
339
340  chks(
341    x = x, warn = warn,
342    chk("must be one of 'unix' and 'windows'",
343        x$value %in% c("unix", "windows"))
344  )
345}
346
347##' @export
348##' @method check_field DescriptionType
349
350check_field.DescriptionType <- function(x, warn = FALSE, ...) {
351
352  chks(
353    x = x, warn = warn,
354    chk("must be either 'Package' or 'Translation'",
355        x$value %in% c("Package", "Translation"))
356  )
357}
358
359##' @export
360##' @method check_field DescriptionClassification
361
362check_field.DescriptionClassification <- function(x, warn = FALSE, ...) {
363  TRUE
364}
365
366##' @export
367##' @method check_field DescriptionLanguage
368
369check_field.DescriptionLanguage <- function(x, warn = FALSE, ...) {
370
371  is_language_list <- function(x) {
372    x <- str_trim(strsplit(x, ",", fixed = TRUE)[[1]])
373    all(grepl("^[a-z][a-z][a-z]?(-[A-Z]+)?$", x))
374  }
375
376  chks(
377    x = x, warn = warn,
378    chk("must be a list of IETF language codes defined by RFC 5646",
379        is_language_list(x$value))
380  )
381}
382
383##' @export
384##' @method check_field DescriptionDate
385
386check_field.DescriptionDate <- function(x, warn = FALSE, ...) {
387
388  chks(
389    x = x, warn = warn,
390    chk(
391      paste0(
392        "must be an ISO date: yyyy-mm-dd, but it is actually better\n",
393        "to leave this field out completely. It is not required."),
394      grepl("^[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]$", x$value)
395    )
396  )
397}
398
399##' @export
400##' @method check_field DescriptionCompression
401
402check_field.DescriptionCompression <- function(x, warn = FALSE, ...) {
403
404  chks(
405    x = x, warn = warn,
406    chk("must be one of 'bzip2', 'xz', 'gzip'",
407        x$value %in% c("bzip2", "xz", "gzip"))
408  )
409}
410
411##' @export
412##' @method check_field DescriptionRepository
413
414check_field.DescriptionRepository <- function(x, warn = FALSE, ...) {
415  TRUE
416}
417
418##' @export
419##' @method check_field DescriptionFreeForm
420
421check_field.DescriptionFreeForm <- function(x, warn = FALSE, ...) {
422  TRUE
423}
424
425##' @export
426##' @method check_field DescriptionAddedByRCMD
427
428check_field.DescriptionAddedByRCMD <- function(x, warn = FALSE, ...) {
429  TRUE
430}
431