diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/lint.scm | 79 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 17 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 16 |
3 files changed, 64 insertions, 48 deletions
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index c40d76b558..cced1bda66 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -19,6 +19,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts lint) + #:use-module (guix store) #:use-module (guix base32) #:use-module (guix download) #:use-module (guix ftp-client) @@ -32,6 +33,8 @@ #:use-module (ice-9 regex) #:use-module (ice-9 format) #:use-module (web uri) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module ((guix build download) #:select (maybe-expand-mirrors open-connection-for-uri)) @@ -41,12 +44,15 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:export (guix-lint check-description-style check-inputs-should-be-native - check-patches + check-patch-file-names check-synopsis-style + check-derivation check-home-page check-source)) @@ -348,26 +354,30 @@ warning for PACKAGE mentionning the FIELD." (package-home-page package)) 'home-page))))) -(define (check-patches package) - ;; Emit a warning if the patches requires by PACKAGE are badly named. - (let ((patches (and=> (package-source package) origin-patches)) - (name (package-name package)) - (full-name (package-full-name package))) - (when (and patches - (any (match-lambda - ((? string? patch) - (let ((filename (basename patch))) - (not (or (eq? (string-contains filename name) 0) - (eq? (string-contains filename full-name) - 0))))) - (_ - ;; This must be an <origin> or something like that. - #f)) - patches)) - (emit-warning package - (_ "file names of patches should start with \ +(define (check-patch-file-names package) + "Emit a warning if the patches requires by PACKAGE are badly named or if the +patch could not be found." + (guard (c ((message-condition? c) ;raised by 'search-patch' + (emit-warning package (condition-message c) + 'patch-file-names))) + (let ((patches (and=> (package-source package) origin-patches)) + (name (package-name package)) + (full-name (package-full-name package))) + (when (and patches + (any (match-lambda + ((? string? patch) + (let ((file (basename patch))) + (not (or (eq? (string-contains file name) 0) + (eq? (string-contains file full-name) + 0))))) + (_ + ;; This must be an <origin> or something like that. + #f)) + patches)) + (emit-warning package + (_ "file names of patches should start with \ the package name") - 'patches)))) + 'patch-file-names))))) (define (escape-quotes str) "Replace any quote character in STR by an escaped quote character." @@ -434,6 +444,25 @@ descriptions maintained upstream." (append-map (cut maybe-expand-mirrors <> %mirrors) uris)))))) +(define (check-derivation package) + "Emit a warning if we fail to compile PACKAGE to a derivation." + (catch #t + (lambda () + (guard (c ((nix-protocol-error? c) + (emit-warning package + (format #f (_ "failed to create derivation: ~a") + (nix-protocol-error-message c)))) + ((message-condition? c) + (emit-warning package + (format #f (_ "failed to create derivation: ~a") + (condition-message c))))) + (with-store store + (package-derivation store package)))) + (lambda args + (emit-warning package + (format #f (_ "failed to create derivation: ~s~%") + args))))) + ;;; @@ -455,9 +484,9 @@ descriptions maintained upstream." (description "Identify inputs that should be native inputs") (check check-inputs-should-be-native)) (lint-checker - (name 'patch-filenames) - (description "Validate file names of patches") - (check check-patches)) + (name 'patch-file-names) + (description "Validate file names and availability of patches") + (check check-patch-file-names)) (lint-checker (name 'home-page) (description "Validate home-page URLs") @@ -467,6 +496,10 @@ descriptions maintained upstream." (description "Validate source URLs") (check check-source)) (lint-checker + (name 'derivation) + (description "Report failure to compile a package to a derivation") + (check check-derivation)) + (lint-checker (name 'synopsis) (description "Validate package synopses") (check check-synopsis-style)))) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 04886499a2..28519d78e2 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; @@ -207,16 +207,13 @@ update would trigger a complete rebuild." (list-dependent? (assoc-ref opts 'list-dependent?)) (key-download (assoc-ref opts 'key-download)) (packages - (match (concatenate - (filter-map (match-lambda - (('argument . value) - (let ((p (find-packages-by-name value))) - (when (null? p) - (leave (_ "~a: no package by that name~%") - value)) - p)) + (match (filter-map (match-lambda + (('argument . spec) + ;; Take either the specified version or the + ;; latest one. + (specification->package spec)) (_ #f)) - opts)) + opts) (() ; default to all packages (let ((select? (match (assoc-ref opts 'select) ('core core-package?) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 1b64e6fb92..1838e89452 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -69,21 +69,7 @@ (set-current-module %user-module) (primitive-load file)))) (lambda args - (match args - (('system-error . _) - (let ((err (system-error-errno args))) - (leave (_ "failed to open operating system file '~a': ~a~%") - file (strerror err)))) - (('syntax-error proc message properties form . rest) - (let ((loc (source-properties->location properties))) - (format (current-error-port) (_ "~a: error: ~a~%") - (location->string loc) message) - (exit 1))) - ((error args ...) - (report-error (_ "failed to load operating system file '~a':~%") - file) - (apply display-error #f (current-error-port) args) - (exit 1)))))) + (report-load-error file args)))) ;;; |