mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-19 05:57:04 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

lint: Report patches that cannot be found.

Browse source 
* guix/scripts/lint.scm (check-patch-file-names): Wrap body in 'guard'.
* tests/lint.scm ("patches: not found"): New test.
This commit is contained in:
Ludovic Courtès 2015-04-10 10:27:26 +02:00
parent 56b1b74c90
commit b210b35d61
2 changed files with 40 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

44
guix/scripts/lint.scm
View file

@ -41,6 +41,8 @@ (define-module (guix scripts lint)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-37) #:use-module (srfi srfi-37)
#:export (guix-lint #:export (guix-lint
check-description-style check-description-style
@ -349,25 +351,29 @@ (define (check-home-page package)
'home-page))))) 'home-page)))))
(define (check-patch-file-names package) (define (check-patch-file-names package)
;; Emit a warning if the patches requires by PACKAGE are badly named. "Emit a warning if the patches requires by PACKAGE are badly named or if the
(let ((patches (and=> (package-source package) origin-patches)) patch could not be found."
(name (package-name package)) (guard (c ((message-condition? c) ;raised by 'search-patch'
(full-name (package-full-name package))) (emit-warning package (condition-message c)
(when (and patches 'patch-file-names)))
(any (match-lambda (let ((patches (and=> (package-source package) origin-patches))
((? string? patch) (name (package-name package))
(let ((file (basename patch))) (full-name (package-full-name package)))
(not (or (eq? (string-contains file name) 0) (when (and patches
(eq? (string-contains file full-name) (any (match-lambda
0))))) ((? string? patch)
(_ (let ((file (basename patch)))
;; This must be an <origin> or something like that. (not (or (eq? (string-contains file name) 0)
#f)) (eq? (string-contains file full-name)
patches)) 0)))))
(emit-warning package (_
(_ "file names of patches should start with \ ;; This must be an <origin> or something like that.
#f))
patches))
(emit-warning package
(_ "file names of patches should start with \
the package name") the package name")
'patch-file-names)))) 'patch-file-names)))))
(define (escape-quotes str) (define (escape-quotes str)
"Replace any quote character in STR by an escaped quote character." "Replace any quote character in STR by an escaped quote character."
@ -456,7 +462,7 @@ (define %checkers
(check check-inputs-should-be-native)) (check check-inputs-should-be-native))
(lint-checker (lint-checker
(name 'patch-file-names) (name 'patch-file-names)
(description "Validate file names of patches") (description "Validate file names and availability of patches")
(check check-patch-file-names)) (check check-patch-file-names))
(lint-checker (lint-checker
(name 'home-page) (name 'home-page)

15
tests/lint.scm
View file

@ -304,6 +304,21 @@ (define-syntax-rule (with-warnings body ...)
(check-patch-file-names pkg))) (check-patch-file-names pkg)))
"file names of patches should start with the package name"))) "file names of patches should start with the package name")))
(test-assert "patches: not found"
(->bool
(string-contains
(with-warnings
(let ((pkg (dummy-package "x"
(source
(origin
(method url-fetch)
(uri "someurl")
(sha256 "somesha")
(patches
(list (search-patch "this-patch-does-not-exist!"))))))))
(check-patch-file-names pkg)))
"patch not found")))
(test-assert "home-page: wrong home-page" (test-assert "home-page: wrong home-page"
(->bool (->bool
(string-contains (string-contains