diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/texlive.scm | 164 | ||||
| -rw-r--r-- | guix/build/syscalls.scm | 123 | ||||
| -rw-r--r-- | guix/build/texlive-build-system.scm | 89 | ||||
| -rw-r--r-- | guix/derivations.scm | 47 | ||||
| -rw-r--r-- | guix/discovery.scm | 61 | ||||
| -rw-r--r-- | guix/grafts.scm | 2 | ||||
| -rw-r--r-- | guix/import/pypi.scm | 6 | ||||
| -rw-r--r-- | guix/import/texlive.scm | 182 | ||||
| -rw-r--r-- | guix/licenses.scm | 71 | ||||
| -rw-r--r-- | guix/packages.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/graph.scm | 8 | ||||
| -rw-r--r-- | guix/scripts/import.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/import/texlive.scm | 101 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 76 | ||||
| -rw-r--r-- | guix/scripts/perform-download.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 6 | ||||
| -rw-r--r-- | guix/store.scm | 39 | ||||
| -rw-r--r-- | guix/svn-download.scm | 23 | ||||
| -rw-r--r-- | guix/ui.scm | 35 |
21 files changed, 940 insertions, 114 deletions
diff --git a/guix/build-system/texlive.scm b/guix/build-system/texlive.scm new file mode 100644 index 0000000000..d4085ea7e8 --- /dev/null +++ b/guix/build-system/texlive.scm @@ -0,0 +1,164 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build-system texlive) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (guix svn-download) + #:use-module (ice-9 match) + #:export (%texlive-build-system-modules + texlive-build + texlive-build-system + texlive-ref + %texlive-tag + %texlive-revision)) + +;; Commentary: +;; +;; Standard build procedure for Texlive packages. +;; +;; Code: + +;; These variables specify the SVN tag and the matching SVN revision. +(define %texlive-tag "texlive-2017.0") +(define %texlive-revision 44445) + +(define (texlive-ref component id) + "Return a <svn-reference> object for the package ID, which is part of the +given Texlive COMPONENT." + (svn-reference + (url (string-append "svn://www.tug.org/texlive/tags/" + %texlive-tag "/Master/texmf-dist/" + "source/" component "/" id)) + (revision %texlive-revision))) + +(define %texlive-build-system-modules + ;; Build-side modules imported by default. + `((guix build texlive-build-system) + ,@%gnu-build-system-modules)) + +(define (default-texlive-bin) + "Return the default texlive-bin package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((tex-mod (resolve-interface '(gnu packages tex)))) + (module-ref tex-mod 'texlive-bin))) + +(define (default-texlive-latex-base) + "Return the default texlive-latex-base package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((tex-mod (resolve-interface '(gnu packages tex)))) + (module-ref tex-mod 'texlive-latex-base))) + +(define* (lower name + #:key + source inputs native-inputs outputs + system target + (texlive-latex-base (default-texlive-latex-base)) + (texlive-bin (default-texlive-bin)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:source #:target #:inputs #:native-inputs + #:texlive-latex-base #:texlive-bin)) + + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (build-inputs `(("texlive-bin" ,texlive-bin) + ("texlive-latex-base" ,texlive-latex-base) + ,@native-inputs)) + (outputs outputs) + (build texlive-build) + (arguments (strip-keyword-arguments private-keywords arguments)))) + +(define* (texlive-build store name inputs + #:key + (tests? #f) + tex-directory + (build-targets #f) + (tex-format "luatex") + (phases '(@ (guix build texlive-build-system) + %standard-phases)) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (substitutable? #t) + (imported-modules %texlive-build-system-modules) + (modules '((guix build texlive-build-system) + (guix build utils)))) + "Build SOURCE with INPUTS." + (define builder + `(begin + (use-modules ,@modules) + (texlive-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:tex-directory ,tex-directory + #:build-targets ,build-targets + #:tex-format ,tex-format + #:system ,system + #:tests? ,tests? + #:phases ,phases + #:outputs %outputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build + #:substitutable? substitutable?)) + +(define texlive-build-system + (build-system + (name 'texlive) + (description "The build system for TeX Live packages") + (lower lower))) + +;;; texlive.scm ends here diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 2def2a108f..9c082b4352 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -28,6 +28,7 @@ #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) @@ -68,6 +69,7 @@ mkdtemp! fdatasync pivot-root + scandir* fcntl-flock set-thread-name @@ -819,6 +821,127 @@ system to PUT-OLD." ;;; +;;; Opendir & co. +;;; + +(define-c-struct %struct-dirent-header + sizeof-dirent-header + (lambda (inode offset length type name) + ;; Convert TYPE to symbols like 'stat:type' does. + (let ((type (cond ((= type DT_REG) 'regular) + ((= type DT_LNK) 'symlink) + ((= type DT_DIR) 'directory) + ((= type DT_FIFO) 'fifo) + ((= type DT_CHR) 'char-special) + ((= type DT_BLK) 'block-special) + ((= type DT_SOCK) 'socket) + (else 'unknown)))) + `((type . ,type) + (inode . ,inode)))) + read-dirent-header + write-dirent-header! + (inode int64) + (offset int64) + (length unsigned-short) + (type uint8) + (name uint8)) ;first byte of 'd_name' + +;; Constants for the 'type' field, from <dirent.h>. +(define DT_UNKNOWN 0) +(define DT_FIFO 1) +(define DT_CHR 2) +(define DT_DIR 4) +(define DT_BLK 6) +(define DT_REG 8) +(define DT_LNK 10) +(define DT_SOCK 12) +(define DT_WHT 14) + +(define string->pointer/utf-8 + (cut string->pointer <> "UTF-8")) + +(define pointer->string/utf-8 + (cut pointer->string <> <> "UTF-8")) + +(define opendir* + (let ((proc (syscall->procedure '* "opendir" '(*)))) + (lambda* (name #:optional (string->pointer string->pointer/utf-8)) + (let-values (((ptr err) + (proc (string->pointer name)))) + (if (null-pointer? ptr) + (throw 'system-error "opendir*" + "~A: ~A" (list name (strerror err)) + (list err)) + ptr))))) + +(define closedir* + (let ((proc (syscall->procedure int "closedir" '(*)))) + (lambda (directory) + (let-values (((ret err) + (proc directory))) + (unless (zero? ret) + (throw 'system-error "closedir" + "closedir: ~A" (list (strerror err)) + (list err))))))) + +(define readdir* + (let ((proc (syscall->procedure '* "readdir64" '(*)))) + (lambda* (directory #:optional (pointer->string pointer->string/utf-8)) + (let ((ptr (proc directory))) + (and (not (null-pointer? ptr)) + (cons (pointer->string + (make-pointer (+ (pointer-address ptr) + (c-struct-field-offset + %struct-dirent-header name))) + -1) + (read-dirent-header + (pointer->bytevector ptr sizeof-dirent-header)))))))) + +(define* (scandir* name #:optional + (select? (const #t)) + (entry<? (lambda (entry1 entry2) + (match entry1 + ((name1 . _) + (match entry2 + ((name2 . _) + (string<? name1 name2))))))) + #:key + (string->pointer string->pointer/utf-8) + (pointer->string pointer->string/utf-8)) + "This procedure improves on Guile's 'scandir' procedure in several ways: + + 1. Systematically encode decode file names using STRING->POINTER and + POINTER->STRING (UTF-8 by default; this works around a defect in Guile 2.0/2.2 + where 'scandir' decodes file names according to the current locale, which is + not always desirable. + + 2. Each entry that is returned has the form (NAME . PROPERTIES). + PROPERTIES is an alist showing additional properties about the entry, as + found in 'struct dirent'. An entry may look like this: + + (\"foo.scm\" (type . regular) (inode . 123456)) + + Callers must be prepared to deal with the case where 'type' is 'unknown' + since some file systems do not provide that information. + + 3. Raise to 'system-error' when NAME cannot be opened." + (let ((directory (opendir* name string->pointer))) + (dynamic-wind + (const #t) + (lambda () + (let loop ((result '())) + (match (readdir* directory pointer->string) + (#f + (sort result entry<?)) + (entry + (loop (if (select? entry) + (cons entry result) + result)))))) + (lambda () + (closedir* directory))))) + + +;;; ;;; Advisory file locking. ;;; diff --git a/guix/build/texlive-build-system.scm b/guix/build/texlive-build-system.scm new file mode 100644 index 0000000000..c1fd9fd9af --- /dev/null +++ b/guix/build/texlive-build-system.scm @@ -0,0 +1,89 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build texlive-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + texlive-build)) + +;; Commentary: +;; +;; Builder-side code of the standard build procedure for TeX Live packages. +;; +;; Code: + +(define (compile-with-latex format file) + (zero? (system* format + "-interaction=batchmode" + "-output-directory=build" + (string-append "&" format) + file))) + +(define* (build #:key inputs build-targets tex-format #:allow-other-keys) + ;; Find additional tex and sty files + (setenv "TEXINPUTS" + (string-append + (getcwd) ":" (getcwd) "/build:" + (string-join + (append-map (match-lambda + ((_ . dir) + (find-files dir + (lambda (_ stat) + (eq? 'directory (stat:type stat))) + #:directories? #t + #:stat stat))) + inputs) + ":"))) + (setenv "TEXFORMATS" + (string-append (assoc-ref inputs "texlive-latex-base") + "/share/texmf-dist/web2c/")) + (setenv "LUAINPUTS" + (string-append (assoc-ref inputs "texlive-latex-base") + "/share/texmf-dist/tex/latex/base/")) + (mkdir "build") + (every (cut compile-with-latex tex-format <>) + (if build-targets build-targets + (find-files "." "\\.ins$")))) + +(define* (install #:key outputs tex-directory #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (target (string-append + out "/share/texmf-dist/tex/" tex-directory))) + (mkdir-p target) + (for-each delete-file (find-files "." "\\.(log|aux)$")) + (for-each (cut install-file <> target) + (find-files "build" ".*")) + #t)) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (delete 'configure) + (replace 'build build) + (delete 'check) + (replace 'install install))) + +(define* (texlive-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given TeX Live package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) + +;;; texlive-build-system.scm ends here diff --git a/guix/derivations.scm b/guix/derivations.scm index b9ad9c9e8c..07803ca94f 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -82,6 +82,7 @@ derivation-hash read-derivation + read-derivation-from-file write-derivation derivation->output-path derivation->output-paths @@ -241,8 +242,7 @@ result is the set of prerequisites of DRV not already in valid." (append inputs result) (fold set-insert input-set inputs) (map (lambda (i) - (call-with-input-file (derivation-input-path i) - read-derivation)) + (read-derivation-from-file (derivation-input-path i))) inputs))))) (define (offloadable-derivation? drv) @@ -295,9 +295,8 @@ substituter many times." ;; info is not already in cache. ;; Also, skip derivations marked as non-substitutable. (append-map (lambda (input) - (let ((drv (call-with-input-file - (derivation-input-path input) - read-derivation))) + (let ((drv (read-derivation-from-file + (derivation-input-path input)))) (if (substitutable-derivation? drv) (derivation-input-output-paths input) '()))) @@ -400,13 +399,15 @@ one-argument procedure similar to that returned by 'substitution-oracle'." (derivation-inputs drv)) substitute) (map (lambda (i) - (call-with-input-file (derivation-input-path i) - read-derivation)) + (read-derivation-from-file + (derivation-input-path i))) inputs) (map derivation-input-sub-derivations inputs))))))) -(define (%read-derivation drv-port) - ;; Actually read derivation from DRV-PORT. +(define (read-derivation drv-port) + "Read the derivation from DRV-PORT and return the corresponding <derivation> +object. Most of the time you'll want to use 'read-derivation-from-file', +which caches things as appropriate and is thus more efficient." (define comma (string->symbol ",")) @@ -482,17 +483,16 @@ one-argument procedure similar to that returned by 'substitution-oracle'." ;; XXX: This is redundant with 'atts-cache' in the store. (make-weak-value-hash-table 200)) -(define (read-derivation drv-port) - "Read the derivation from DRV-PORT and return the corresponding +(define (read-derivation-from-file file) + "Read the derivation in FILE, a '.drv' file, and return the corresponding <derivation> object." - ;; Memoize that operation because `%read-derivation' is quite expensive, + ;; Memoize that operation because 'read-derivation' is quite expensive, ;; and because the same argument is read more than 15 times on average ;; during something like (package-derivation s gdb). - (let ((file (port-filename drv-port))) - (or (and file (hash-ref %derivation-cache file)) - (let ((drv (%read-derivation drv-port))) - (hash-set! %derivation-cache file drv) - drv)))) + (or (and file (hash-ref %derivation-cache file)) + (let ((drv (call-with-input-file file read-derivation))) + (hash-set! %derivation-cache file drv) + drv))) (define-inlinable (write-sequence lst write-item port) ;; Write each element of LST with WRITE-ITEM to PORT, separating them with a @@ -608,8 +608,7 @@ DRV." (define derivation-path->output-path ;; This procedure is called frequently, so memoize it. (let ((memoized (mlambda (path output) - (derivation->output-path (call-with-input-file path - read-derivation) + (derivation->output-path (read-derivation-from-file path) output)))) (lambda* (path #:optional (output "out")) "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store @@ -619,7 +618,7 @@ path of its output OUTPUT." (define (derivation-path->output-paths path) "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the list of name/path pairs of its outputs." - (derivation->output-paths (call-with-input-file path read-derivation))) + (derivation->output-paths (read-derivation-from-file path))) ;;; @@ -630,10 +629,8 @@ list of name/path pairs of its outputs." (mlambda (file) "Return a string containing the base16 representation of the hash of the derivation at FILE." - (call-with-input-file file - (compose bytevector->base16-string - derivation-hash - read-derivation)))) + (bytevector->base16-string + (derivation-hash (read-derivation-from-file file))))) (define derivation-hash ; `hashDerivationModulo' in derivations.cc (mlambda (drv) @@ -896,7 +893,7 @@ recursively." ((_ . replacement) (list replacement)) (#f - (let* ((drv (loop (call-with-input-file path read-derivation)))) + (let* ((drv (loop (read-derivation-from-file path)))) (cons drv sub-drvs)))))))) (let loop ((drv drv)) diff --git a/guix/discovery.scm b/guix/discovery.scm index 319ba7c872..292df2bd9c 100644 --- a/guix/discovery.scm +++ b/guix/discovery.scm @@ -19,6 +19,7 @@ (define-module (guix discovery) #:use-module (guix ui) #:use-module (guix combinators) + #:use-module (guix build syscalls) #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:use-module (ice-9 vlist) @@ -37,29 +38,45 @@ (define* (scheme-files directory) "Return the list of Scheme files found under DIRECTORY, recursively. The -returned list is sorted in alphabetical order." +returned list is sorted in alphabetical order. Return the empty list if +DIRECTORY is not accessible." + (define (entry-type name properties) + (match (assoc-ref properties 'type) + ('unknown + (stat:type (lstat name))) + ((? symbol? type) + type))) - ;; Sort entries so that 'fold-packages' works in a deterministic fashion - ;; regardless of details of the underlying file system. - (sort (file-system-fold (const #t) ;enter? - (lambda (path stat result) ;leaf - (if (string-suffix? ".scm" path) - (cons path result) - result)) - (lambda (path stat result) ;down - result) - (lambda (path stat result) ;up - result) - (const #f) ;skip - (lambda (path stat errno result) - (unless (= ENOENT errno) - (warning (G_ "cannot access `~a': ~a~%") - path (strerror errno))) - result) - '() - directory - stat) - string<?)) + ;; Use 'scandir*' so we can avoid an extra 'lstat' for each entry, as + ;; opposed to Guile's 'scandir' or 'file-system-fold'. + (fold-right (lambda (entry result) + (match entry + (("." . _) + result) + ((".." . _) + result) + ((name . properties) + (let ((absolute (string-append directory "/" name))) + (case (entry-type absolute properties) + ((directory) + (append (scheme-files absolute) result)) + ((regular symlink) + ;; XXX: We don't recurse if we find a symlink. + (if (string-suffix? ".scm" name) + (cons absolute result) + result)) + (else + result)))))) + '() + (catch 'system-error + (lambda () + (scandir* directory)) + (lambda args + (let ((errno (system-error-errno args))) + (unless (= errno ENOENT) + (warning (G_ "cannot access `~a': ~a~%") + directory (strerror errno))) + '()))))) (define file-name->module-name (let ((not-slash (char-set-complement (char-set #\/)))) diff --git a/guix/grafts.scm b/guix/grafts.scm index 11885db226..d6b0e93e8d 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -156,7 +156,7 @@ name of the output of that derivation ITEM corresponds to (for example (() ;ITEM is a plain file (values #f #f)) ((drv-file _ ...) - (let ((drv (call-with-input-file drv-file read-derivation))) + (let ((drv (read-derivation-from-file drv-file))) (values drv (any (match-lambda ((name . path) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 9c72e73314..90dbe56128 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -258,11 +258,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." ;; Sometimes 'pypi-uri' doesn't quite work due to mixed ;; cases in NAME, for instance, as is the case with ;; "uwsgi". In that case, fall back to a full URL. - (uri ,(if (equal? (pypi-uri name version) source-url) - `(pypi-uri ,name version) - `(string-append - ,@(factorize-uri source-url version)))) - + (uri (pypi-uri ,(string-downcase name) version)) (sha256 (base32 ,(guix-hash-url temp))))) diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm new file mode 100644 index 0000000000..d4c3714364 --- /dev/null +++ b/guix/import/texlive.scm @@ -0,0 +1,182 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix import texlive) + #:use-module (ice-9 match) + #:use-module (sxml simple) + #:use-module (sxml xpath) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (web uri) + #:use-module (guix http-client) + #:use-module (guix hash) + #:use-module (guix memoization) + #:use-module (guix store) + #:use-module (guix base32) + #:use-module (guix serialization) + #:use-module (guix svn-download) + #:use-module (guix import utils) + #:use-module (guix utils) + #:use-module (guix upstream) + #:use-module (guix packages) + #:use-module (gnu packages) + #:use-module (guix build-system texlive) + #:export (texlive->guix-package)) + +;;; Commentary: +;;; +;;; Generate a package declaration template for the latest version of a +;;; package on CTAN, using the XML output produced by the XML API to the CTAN +;;; database at http://www.ctan.org/xml/1.2/ +;;; +;;; Instead of taking the packages from CTAN, however, we fetch the sources +;;; from the SVN repository of the Texlive project. We do this because CTAN +;;; only keeps a single version of each package whereas we can access any +;;; version via SVN. Unfortunately, this means that the importer is really +;;; just a Texlive importer, not a generic CTAN importer. +;;; +;;; Code: + +(define string->license + (match-lambda + ("artistic2" 'gpl3+) + ("gpl" 'gpl3+) + ("gpl1" 'gpl1) + ("gpl1+" 'gpl1+) + ("gpl2" 'gpl2) + ("gpl2+" 'gpl2+) + ("gpl3" 'gpl3) + ("gpl3+" 'gpl3+) + ("lgpl2.1" 'lgpl2.1) + ("lgpl3" 'lgpl3) + ("knuth" 'knuth) + ("pd" 'public-domain) + ("bsd2" 'bsd-2) + ("bsd3" 'bsd-3) + ("bsd4" 'bsd-4) + ("opl" 'opl1.0+) + ("ofl" 'silofl1.1) + ("lppl" 'lppl) + ("lppl1" 'lppl1.0+) ; usually means "or later" + ("lppl1.2" 'lppl1.2+) ; usually means "or later" + ("lppl1.3" 'lppl1.3+) ; usually means "or later" + ("lppl1.3a" 'lppl1.3a) + ("lppl1.3b" 'lppl1.3b) + ("lppl1.3c" 'lppl1.3c) + ("cc-by-2" 'cc-by-2.0) + ("cc-by-3" 'cc-by-3.0) + ("cc-by-sa-2" 'cc-by-sa2.0) + ("cc-by-sa-3" 'cc-by-sa3.0) + ("mit" 'expat) + ("fdl" 'fdl1.3+) + ("gfl" 'gfl1.0) + + ;; These are known non-free licenses + ("noinfo" 'unknown) + ("nosell" 'non-free) + ("shareware" 'non-free) + ("nosource" 'non-free) + ("nocommercial" 'non-free) + ("cc-by-nc-nd-1" 'non-free) + ("cc-by-nc-nd-2" 'non-free) + ("cc-by-nc-nd-2.5" 'non-free) + ("cc-by-nc-nd-3" 'non-free) + ("cc-by-nc-nd-4" 'non-free) + ((x) (string->license x)) + ((lst ...) `(list ,@(map string->license lst))) + (_ #f))) + +(define (fetch-sxml name) + "Return an sxml representation of the package information contained in the +XML description of the CTAN package or #f in case of failure." + ;; This API always returns the latest release of the module. + (let ((url (string-append "http://www.ctan.org/xml/1.2/pkg/" name))) + (guard (c ((http-get-error? c) + (format (current-error-port) + "error: failed to retrieve package information \ +from ~s: ~a (~s)~%" + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + #f)) + (xml->sxml (http-fetch url) + #:trim-whitespace? #t)))) + +(define (guix-name component name) + "Return a Guix package name for a given Texlive package NAME." + (string-append "texlive-" component "-" + (string-map (match-lambda + (#\_ #\-) + (#\. #\-) + (chr (char-downcase chr))) + name))) + +(define* (sxml->package sxml #:optional (component "latex")) + "Return the `package' s-expression for a Texlive package from the SXML +expression describing it." + (define (sxml-value path) + (match ((sxpath path) sxml) + (() #f) + ((val) val))) + (with-store store + (let* ((id (sxml-value '(entry @ id *text*))) + (synopsis (sxml-value '(entry caption *text*))) + (version (or (sxml-value '(entry version @ number *text*)) + (sxml-value '(entry version @ date *text*)))) + (license (string->license (sxml-value '(entry license @ type *text*)))) + (home-page (string-append "http://www.ctan.org/pkg/" id)) + (ref (texlive-ref component id)) + (checkout (download-svn-to-store store ref))) + `(package + (name ,(guix-name component id)) + (version ,version) + (source (origin + (method svn-fetch) + (uri (texlive-ref ,component ,id)) + (sha256 + (base32 + ,(bytevector->nix-base32-string + (let-values (((port get-hash) (open-sha256-port))) + (write-file checkout port) + (force-output port) + (get-hash))))))) + (build-system texlive-build-system) + (arguments ,`(,'quote (#:tex-directory ,(string-join (list component id) "/")))) + (home-page ,home-page) + (synopsis ,synopsis) + (description ,(string-trim-both + (string-join + (map string-trim-both + (string-split + (beautify-description + (sxml->string (or (sxml-value '(entry description)) + '()))) + #\newline))))) + (license ,license))))) + +(define texlive->guix-package + (memoize + (lambda* (package-name #:optional (component "latex")) + "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' +s-expression corresponding to that package, or #f on failure." + (and=> (fetch-sxml package-name) + (cut sxml->package <> component))))) + +;;; ctan.scm ends here diff --git a/guix/licenses.scm b/guix/licenses.scm index 6845b89d90..1bed56af20 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -60,7 +60,13 @@ ibmpl1.0 imlib2 ipa + knuth lgpl2.0 lgpl2.0+ lgpl2.1 lgpl2.1+ lgpl3 lgpl3+ + lppl lppl1.0+ lppl1.2 lppl1.2+ + lppl1.3 lppl1.3+ + lppl1.3a lppl1.3a+ + lppl1.3b lppl1.3b+ + lppl1.3c lppl1.3c+ mpl1.0 mpl1.1 mpl2.0 ms-pl ncsa @@ -351,6 +357,11 @@ at URI, which may be a file:// URI pointing the package's tree." "http://directory.fsf.org/wiki/License:IPA_Font_License" "https://www.gnu.org/licenses/license-list#IPAFONT")) +(define knuth + (license "Donald Knuth's license for TeX" + "http://www.ctan.org/license/knuth" + "Modification are only permitted under a different name.")) + (define lgpl2.0 (license "LGPL 2.0" "https://www.gnu.org/licenses/old-licenses/lgpl-2.0.html" @@ -381,6 +392,66 @@ at URI, which may be a file:// URI pointing the package's tree." "https://www.gnu.org/licenses/lgpl.html" "https://www.gnu.org/licenses/license-list#LGPLv3")) +(define lppl + (license "LPPL (any version)" + "https://www.latex-project.org/lppl/lppl-1-0/" + "LaTeX Project Public License 1.0")) + +(define lppl1.0+ + (license "LPPL 1.0+" + "https://www.latex-project.org/lppl/lppl-1-0/" + "LaTeX Project Public License 1.0")) + +(define lppl1.2 + (license "LPPL 1.2" + "http://directory.fsf.org/wiki/License:LPPLv1.2" + "https://www.gnu.org/licenses/license-list#LPPL-1.2")) + +(define lppl1.2+ + (license "LPPL 1.2+" + "http://directory.fsf.org/wiki/License:LPPLv1.2" + "https://www.gnu.org/licenses/license-list#LPPL-1.2")) + +(define lppl1.3 + (license "LPPL 1.3" + "https://www.latex-project.org/lppl/lppl-1-3/" + "LaTeX Project Public License 1.3")) + +(define lppl1.3+ + (license "LPPL 1.3+" + "https://www.latex-project.org/lppl/lppl-1-3/" + "LaTeX Project Public License 1.3+")) + +(define lppl1.3a + (license "LPPL 1.3a" + "http://directory.fsf.org/wiki/License:LPPLv1.3a" + "https://www.gnu.org/licenses/license-list#LPPL-1.3a")) + +(define lppl1.3a+ + (license "LPPL 1.3a+" + "http://directory.fsf.org/wiki/License:LPPLv1.3a" + "https://www.gnu.org/licenses/license-list#LPPL-1.3a")) + +(define lppl1.3b + (license "LPPL 1.3b" + "https://www.latex-project.org/lppl/lppl-1-3b/" + "LaTeX Project Public License 1.3b")) + +(define lppl1.3b+ + (license "LPPL 1.3b+" + "https://www.latex-project.org/lppl/lppl-1-3b/" + "LaTeX Project Public License 1.3b or later")) + +(define lppl1.3c + (license "LPPL 1.3c" + "https://www.latex-project.org/lppl/lppl-1-3c/" + "LaTeX Project Public License 1.3c")) + +(define lppl1.3c+ + (license "LPPL 1.3c+" + "https://www.latex-project.org/lppl/lppl-1-3c/" + "LaTeX Project Public License 1.3c or later")) + (define mpl1.0 (license "MPL 1.0" "http://www.mozilla.org/MPL/1.0/" diff --git a/guix/packages.scm b/guix/packages.scm index 97580352e2..cea3a7472f 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -477,10 +477,10 @@ specifies modules in scope when evaluating SNIPPET." (define instantiate-patch (match-lambda - ((? string? patch) + ((? string? patch) ;deprecated (interned-file patch #:recursive? #t)) - ((? origin? patch) - (origin->derivation patch system)))) + ((? struct? patch) ;origin, local-file, etc. + (lower-object patch system)))) (mlet %store-monad ((tar -> (lookup-input "tar")) (xz -> (lookup-input "xz")) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 558e8e7719..0571b874f1 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -87,7 +87,7 @@ found. Return #f if no build log was found." ;; Usually we'll have more luck with the output file name since ;; the deriver that was used by the server could be different, so ;; try one of the output file names. - (let ((drv (call-with-input-file file read-derivation))) + (let ((drv (read-derivation-from-file file))) (or (find-url (derivation->output-path drv)) (find-url file)))) (lambda args @@ -599,7 +599,7 @@ build---packages, gexps, derivations, and so on." (append-map (match-lambda (('argument . (? string? spec)) (cond ((derivation-path? spec) - (list (call-with-input-file spec read-derivation))) + (list (read-derivation-from-file spec))) ((store-path? spec) ;; Nothing to do; maybe for --log-file. '()) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 0af1fa3ad3..d5be442884 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -221,15 +221,11 @@ GNU-BUILD-SYSTEM have zero dependencies." ;;; Derivation DAG. ;;; -(define (file->derivation file) - "Read the derivation from FILE and return it." - (call-with-input-file file read-derivation)) - (define (derivation-dependencies obj) "Return the <derivation> objects and store items corresponding to the dependencies of OBJ, a <derivation> or store item." (if (derivation? obj) - (append (map (compose file->derivation derivation-input-path) + (append (map (compose read-derivation-from-file derivation-input-path) (derivation-inputs obj)) (derivation-sources obj)) '())) @@ -263,7 +259,7 @@ a plain store file." ((? derivation-path? item) (mbegin %store-monad ((store-lift add-temp-root) item) - (return (list (file->derivation item))))) + (return (list (read-derivation-from-file item))))) (x (raise (condition (&message (message "unsupported argument for \ diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 203cda8049..9bba074e8c 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -74,7 +74,7 @@ rather than \\n." ;;; (define importers '("gnu" "nix" "pypi" "cpan" "hackage" "stackage" "elpa" "gem" - "cran" "crate")) + "cran" "crate" "texlive")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/texlive.scm b/guix/scripts/import/texlive.scm new file mode 100644 index 0000000000..1cceee7051 --- /dev/null +++ b/guix/scripts/import/texlive.scm @@ -0,0 +1,101 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts import texlive) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import texlive) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-texlive)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (G_ "Usage: guix import texlive PACKAGE-NAME +Import and convert the Texlive package for PACKAGE-NAME.\n")) + (display (G_ " + -a, --archive=ARCHIVE specify the archive repository")) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import texlive"))) + (option '(#\a "archive") #t #f + (lambda (opt name arg result) + (alist-cons 'component arg + (alist-delete 'component result)))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-texlive . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (G_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((package-name) + (let ((sexp (texlive->guix-package package-name + (or (assoc-ref opts 'component) + "latex")))) + (unless sexp + (leave (G_ "failed to download description for package '~a'~%") + package-name)) + sexp)) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 77b340cff6..566d117b02 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -652,9 +652,8 @@ machine." (with-error-handling (process-request (equal? (match:substring match 1) "1") (match:substring match 2) ; system - (call-with-input-file - (match:substring match 3) - read-derivation) + (read-derivation-from-file + (match:substring match 3)) (string-tokenize (match:substring match 4) not-coma) #:print-build-trace? print-build-trace? diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index f050fad976..a6bfb03ae4 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -39,6 +39,7 @@ #:select (directory-exists? mkdir-p)) #:use-module (ice-9 format) #:use-module (ice-9 match) + #:use-module (ice-9 regex) #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -238,32 +239,45 @@ specified in MANIFEST, a manifest object." ;;; (define (find-packages-by-description regexps) - "Return the list of packages whose name matches one of REGEXPS, or whose -synopsis or description matches all of REGEXPS." - (define version<? (negate version>=?)) - - (define (matches-all? str) - (every (cut regexp-exec <> str) regexps)) - - (define (matches-one? str) - (find (cut regexp-exec <> str) regexps)) - - (sort - (fold-packages (lambda (package result) - (if (or (matches-one? (package-name package)) - (and=> (package-synopsis package) - (compose matches-all? P_)) - (and=> (package-description package) - (compose matches-all? P_))) - (cons package result) - result)) - '()) - (lambda (p1 p2) - (case (string-compare (package-name p1) (package-name p2) - (const '<) (const '=) (const '>)) - ((=) (version<? (package-version p1) (package-version p2))) - ((<) #t) - (else #f))))) + "Return two values: the list of packages whose name, synopsis, or +description matches at least one of REGEXPS sorted by relevance, and the list +of relevance scores." + (define (score str) + (let ((counts (filter-map (lambda (regexp) + (match (regexp-exec regexp str) + (#f #f) + (m (match:count m)))) + regexps))) + ;; Compute a score that's proportional to the number of regexps matched + ;; and to the number of matches for each regexp. + (* (length counts) (reduce + 0 counts)))) + + (define (package-score package) + (+ (* 3 (score (package-name package))) + (* 2 (match (package-synopsis package) + ((? string? str) (score (P_ str))) + (#f 0))) + (match (package-description package) + ((? string? str) (score (P_ str))) + (#f 0)))) + + (let ((matches (fold-packages (lambda (package result) + (match (package-score package) + ((? zero?) + result) + (score + (cons (list package score) result)))) + '()))) + (unzip2 (sort matches + (lambda (m1 m2) + (match m1 + ((package1 score1) + (match m2 + ((package2 score2) + (if (= score1 score2) + (string>? (package-full-name package1) + (package-full-name package2)) + (> score1 score2))))))))))) (define (transaction-upgrade-entry entry transaction) "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a @@ -752,8 +766,14 @@ processed, #f otherwise." opts)) (regexps (map (cut make-regexp* <> regexp/icase) patterns))) (leave-on-EPIPE - (for-each (cute package->recutils <> (current-output-port)) - (find-packages-by-description regexps))) + (let-values (((packages scores) + (find-packages-by-description regexps))) + (for-each (lambda (package score) + (package->recutils package (current-output-port) + #:extra-fields + `((relevance . ,score)))) + packages + scores))) #t)) (('show requested-name) diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index aee506af46..18e2fc92f2 100644 --- a/guix/scripts/perform-download.scm +++ b/guix/scripts/perform-download.scm @@ -106,11 +106,11 @@ of GnuTLS over HTTPS, before we have built GnuTLS. See (match args (((? derivation-path? drv) (? store-path? output)) (assert-low-privileges) - (perform-download (call-with-input-file drv read-derivation) + (perform-download (read-derivation-from-file drv) output)) (((? derivation-path? drv)) ;backward compatibility (assert-low-privileges) - (perform-download (call-with-input-file drv read-derivation))) + (perform-download (read-derivation-from-file drv))) (("--version") (show-version-and-exit)) (x diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index c49c0c3e20..a7e3e6d629 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -225,10 +225,6 @@ compression disabled~%")) ("WantMassQuery" . 0) ("Priority" . 100))) -(define (load-derivation file) - "Read the derivation from FILE." - (call-with-input-file file read-derivation)) - (define (signed-string s) "Sign the hash of the string S with the daemon's key." (let* ((public-key (%public-key)) @@ -286,7 +282,7 @@ References: ~a~%~a" base-info (catch 'system-error (lambda () - (let ((drv (load-derivation deriver))) + (let ((drv (read-derivation-from-file deriver))) (format #f "~aSystem: ~a~%Deriver: ~a~%" base-info (derivation-system drv) (basename deriver)))) diff --git a/guix/store.scm b/guix/store.scm index c94dfea959..2acab6b1a3 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -718,6 +718,37 @@ encoding conversion errors." (let loop ((done? (process-stderr server))) (or done? (process-stderr server))))) +(define %rpc-calls + ;; Mapping from RPC names (symbols) to invocation counts. + (make-hash-table)) + +(define* (show-rpc-profile #:optional (port (current-error-port))) + "Write to PORT a summary of the RPCs that have been made." + (let ((profile (sort (hash-fold alist-cons '() %rpc-calls) + (lambda (rpc1 rpc2) + (< (cdr rpc1) (cdr rpc2)))))) + (format port "Remote procedure call summary: ~a RPCs~%" + (match profile + (((names . counts) ...) + (reduce + 0 counts)))) + (for-each (match-lambda + ((rpc . count) + (format port " ~30a ... ~5@a~%" rpc count))) + profile))) + +(define record-operation + ;; Optionally, increment the number of calls of the given RPC. + (let ((profiled (or (and=> (getenv "GUIX_PROFILING") string-tokenize) + '()))) + (if (member "rpc" profiled) + (begin + (add-hook! exit-hook show-rpc-profile) + (lambda (name) + (let ((count (or (hashq-ref %rpc-calls name) 0))) + (hashq-set! %rpc-calls name (+ count 1))))) + (lambda (_) + #t)))) + (define-syntax operation (syntax-rules () "Define a client-side RPC stub for the given operation." @@ -725,6 +756,7 @@ encoding conversion errors." (lambda (server arg ...) docstring (let ((s (nix-server-socket server))) + (record-operation 'name) (write-int (operation-id name) s) (write-arg type arg s) ... @@ -830,10 +862,11 @@ bits are kept. HASH-ALGO must be a string such as \"sha256\". When RECURSIVE? is true, call (SELECT? FILE STAT) for each directory entry, where FILE is the entry's absolute file name and STAT is the result of 'lstat'; exclude entries for which SELECT? does not return true." - (let* ((st (false-if-exception (lstat file-name))) - (args `(,st ,basename ,recursive? ,hash-algo ,select?)) + ;; Note: We don't stat FILE-NAME at each call, and thus we assume that + ;; the file remains unchanged for the lifetime of SERVER. + (let* ((args `(,file-name ,basename ,recursive? ,hash-algo ,select?)) (cache (nix-server-add-to-store-cache server))) - (or (and st (hash-ref cache args)) + (or (hash-ref cache args) (let ((path (add-to-store server basename recursive? hash-algo file-name #:select? select?))) diff --git a/guix/svn-download.scm b/guix/svn-download.scm index c1200fa0c5..c118869af1 100644 --- a/guix/svn-download.scm +++ b/guix/svn-download.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in> +;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,12 +24,15 @@ #:use-module (guix store) #:use-module (guix monads) #:use-module (guix packages) + #:use-module (guix utils) + #:use-module ((guix build svn) #:prefix build:) #:use-module (ice-9 match) #:export (svn-reference svn-reference? svn-reference-url svn-reference-revision - svn-fetch)) + svn-fetch + download-svn-to-store)) ;;; Commentary: ;;; @@ -79,4 +83,21 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #:guile-for-build guile #:local-build? #t))) +(define* (download-svn-to-store store ref + #:optional (name (basename (svn-reference-url ref))) + #:key (log (current-error-port))) + "Download from REF, a <svn-reference> object to STORE. Write progress +reports to LOG." + (call-with-temporary-directory + (lambda (temp) + (let ((result + (parameterize ((current-output-port log)) + (build:svn-fetch (svn-reference-url ref) + (svn-reference-revision ref) + temp + #:user-name (svn-reference-user-name ref) + #:password (svn-reference-password ref))))) + (and result + (add-to-store store name #t "sha256" temp)))))) + ;;; svn-download.scm ends here diff --git a/guix/ui.scm b/guix/ui.scm index 5060fd6dc7..889c9d0228 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -946,9 +946,10 @@ followed by \"+ \", which makes for a valid multi-line field value in the '() str))) -(define* (package->recutils p port #:optional (width (%text-width))) +(define* (package->recutils p port #:optional (width (%text-width)) + #:key (extra-fields '())) "Write to PORT a `recutils' record of package P, arranging to fit within -WIDTH columns." +WIDTH columns. EXTRA-FIELDS is a list of symbol/value pairs to emit." (define width* ;; The available number of columns once we've taken into account space for ;; the initial "+ " prefix. @@ -993,11 +994,11 @@ WIDTH columns." (G_ "unknown")))) (format port "synopsis: ~a~%" (string-map (match-lambda - (#\newline #\space) - (chr chr)) + (#\newline #\space) + (chr chr)) (or (and=> (package-synopsis-string p) P_) ""))) - (format port "~a~2%" + (format port "~a~%" (string->recutils (string-trim-right (parameterize ((%text-width width*)) @@ -1005,7 +1006,16 @@ WIDTH columns." (string-append "description: " (or (and=> (package-description p) P_) "")))) - #\newline)))) + #\newline))) + (for-each (match-lambda + ((field . value) + (let ((field (symbol->string field))) + (format port "~a: ~a~%" + field + (fill-paragraph (object->string value) width* + (string-length field)))))) + extra-fields) + (newline port)) (define (string->generations str) "Return the list of generations matching a pattern in STR. This function @@ -1308,7 +1318,14 @@ found." (parameterize ((program-name command)) ;; Disable canonicalization so we don't don't stat unreasonably. (with-fluids ((%file-port-name-canonicalization #f)) - (apply command-main args))))) + (dynamic-wind + (const #f) + (lambda () + (apply command-main args)) + (lambda () + ;; Abuse 'exit-hook' (which is normally meant to be used by the + ;; REPL) to run things like profiling hooks upon completion. + (run-hook exit-hook))))))) (define (run-guix . args) "Run the 'guix' command defined by command line ARGS. @@ -1316,6 +1333,10 @@ Unlike 'guix-main', this procedure assumes that locale, i18n support, and signal handling has already been set up." (define option? (cut string-prefix? "-" <>)) + ;; The default %LOAD-EXTENSIONS includes the empty string, which doubles the + ;; number of 'stat' calls per entry in %LOAD-PATH. Shamelessly remove it. + (set! %load-extensions '(".scm")) + (match args (() (format (current-error-port) |