lint: Add 'patch-headers' checker.
* guix/lint.scm (check-patch-headers): New procedure.
(%local-checkers): Add 'patch-headers' checker.
* tests/lint.scm ("patch headers: no warnings")
("patch headers: missing comment", "patch headers: empty")
("patch headers: patch not found"): New tests.
This commit is contained in:
Ludovic Courtès
parent
e79ecff045
commit
4f156c259f
@ -35,6 +35,8 @@
|
||||
#:use-module (guix http-client)
|
||||
#:use-module (guix packages)
|
||||
#:use-module (guix i18n)
|
||||
#:use-module ((guix gexp)
|
||||
#:select (local-file? local-file-absolute-file-name))
|
||||
#:use-module (guix licenses)
|
||||
#:use-module (guix records)
|
||||
#:use-module (guix grafts)
|
||||
@ -73,6 +75,7 @@
|
||||
check-inputs-should-be-native
|
||||
check-inputs-should-not-be-an-input-at-all
|
||||
check-patch-file-names
|
||||
check-patch-headers
|
||||
check-synopsis-style
|
||||
check-derivation
|
||||
check-home-page
|
||||
@ -712,6 +715,54 @@ patch could not be found."
|
||||
(_ #f))
|
||||
patches)))))
|
||||
|
||||
(define (check-patch-headers package)
|
||||
"Check that PACKAGE's patches start with a comment. Return a list of
|
||||
warnings."
|
||||
(define (blank? str)
|
||||
(string-every char-set:blank str))
|
||||
|
||||
(define (patch-header-warnings patch)
|
||||
(call-with-input-file patch
|
||||
(lambda (port)
|
||||
;; Read from PORT until a non-blank line is found or EOF is reached.
|
||||
(let loop ()
|
||||
(let ((line (read-line port)))
|
||||
(cond ((eof-object? line)
|
||||
(list (make-warning package
|
||||
(G_ "~a: empty patch")
|
||||
(list (basename patch))
|
||||
#:field 'source)))
|
||||
((blank? line)
|
||||
(loop))
|
||||
((or (string-prefix? "--- " line)
|
||||
(string-prefix? "+++ " line))
|
||||
(list (make-warning package
|
||||
(G_ "~a: patch lacks comment and \
|
||||
upstream status")
|
||||
(list (basename patch))
|
||||
#:field 'source)))
|
||||
(else
|
||||
'())))))))
|
||||
|
||||
(guard (c ((formatted-message? c) ;raised by 'search-patch'
|
||||
(list (%make-warning package
|
||||
(formatted-message-string c)
|
||||
(formatted-message-arguments c)
|
||||
#:field 'source))))
|
||||
(let ((patches (if (origin? (package-source package))
|
||||
(origin-patches (package-source package))
|
||||
'())))
|
||||
(append-map (lambda (patch)
|
||||
;; Dismiss PATCH if it's an origin or similar.
|
||||
(cond ((string? patch)
|
||||
(patch-header-warnings patch))
|
||||
((local-file? patch)
|
||||
(patch-header-warnings
|
||||
(local-file-absolute-file-name patch)))
|
||||
(else
|
||||
'())))
|
||||
patches))))
|
||||
|
||||
(define (escape-quotes str)
|
||||
"Replace any quote character in STR by an escaped quote character."
|
||||
(list->string
|
||||
@ -1417,6 +1468,10 @@ or a list thereof")
|
||||
(name 'patch-file-names)
|
||||
(description "Validate file names and availability of patches")
|
||||
(check check-patch-file-names))
|
||||
(lint-checker
|
||||
(name 'patch-headers)
|
||||
(description "Validate patch headers")
|
||||
(check check-patch-headers))
|
||||
(lint-checker
|
||||
(name 'formatting)
|
||||
(description "Look for formatting issues in the source")
|
||||
|
||||
@ -36,6 +36,8 @@
|
||||
#:use-module (guix lint)
|
||||
#:use-module (guix ui)
|
||||
#:use-module (guix swh)
|
||||
#:use-module ((guix gexp) #:select (local-file))
|
||||
#:use-module ((guix utils) #:select (call-with-temporary-directory))
|
||||
#:use-module (gnu packages)
|
||||
#:use-module (gnu packages glib)
|
||||
#:use-module (gnu packages pkg-config)
|
||||
@ -344,6 +346,60 @@
|
||||
(list (search-patch "this-patch-does-not-exist!"))))))))
|
||||
(check-patch-file-names pkg))))
|
||||
|
||||
(test-assert "patch headers: no warnings"
|
||||
(call-with-temporary-directory
|
||||
(lambda (directory)
|
||||
(call-with-output-file (string-append directory "/t.patch")
|
||||
(lambda (port)
|
||||
(display "This is a patch.\n\n--- a\n+++ b\n"
|
||||
port)))
|
||||
|
||||
(parameterize ((%patch-path (list directory)))
|
||||
(let ((pkg (dummy-package "x"
|
||||
(source (dummy-origin
|
||||
(patches (search-patches "t.patch")))))))
|
||||
(null? (check-patch-headers pkg)))))))
|
||||
|
||||
(test-equal "patch headers: missing comment"
|
||||
"t.patch: patch lacks comment and upstream status"
|
||||
(call-with-temporary-directory
|
||||
(lambda (directory)
|
||||
(call-with-output-file (string-append directory "/t.patch")
|
||||
(lambda (port)
|
||||
(display "\n--- a\n+++ b\n"
|
||||
port)))
|
||||
|
||||
(parameterize ((%patch-path (list directory)))
|
||||
(let ((pkg (dummy-package "x"
|
||||
(source (dummy-origin
|
||||
(patches (search-patches "t.patch")))))))
|
||||
(single-lint-warning-message (check-patch-headers pkg)))))))
|
||||
|
||||
(test-equal "patch headers: empty"
|
||||
"t.patch: empty patch"
|
||||
(call-with-temporary-directory
|
||||
(lambda (directory)
|
||||
(call-with-output-file (string-append directory "/t.patch")
|
||||
(const #t))
|
||||
|
||||
(parameterize ((%patch-path '()))
|
||||
(let ((pkg (dummy-package "x"
|
||||
(source (dummy-origin
|
||||
(patches
|
||||
(list (local-file
|
||||
(string-append directory
|
||||
"/t.patch")))))))))
|
||||
(single-lint-warning-message (check-patch-headers pkg)))))))
|
||||
|
||||
(test-equal "patch headers: patch not found"
|
||||
"does-not-exist.patch: patch not found\n"
|
||||
(parameterize ((%patch-path '()))
|
||||
(let ((pkg (dummy-package "x"
|
||||
(source (dummy-origin
|
||||
(patches
|
||||
(search-patches "does-not-exist.patch")))))))
|
||||
(single-lint-warning-message (check-patch-headers pkg)))))
|
||||
|
||||
(test-equal "derivation: invalid arguments"
|
||||
"failed to create x86_64-linux derivation: (wrong-type-arg \"map\" \"Wrong type argument: ~S\" (invalid-module) ())"
|
||||
(match (let ((pkg (dummy-package "x"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user