me
/
guix
Archived
1
0
Fork 0
Code

guix-package: Report `--search' matches in recutils format. 

* guix/ui.scm (fill-paragraph, string->recutils, package->recutils): New
  procedures.
* guix-package.in (guix-package)[process-query]: Use `package->recutils'
  to display package meta-data.
* tests/guix-package.sh: Adjust test.
* tests/ui.scm: New file.
* Makefile.am (TESTS): Add it.
* doc/guix.texi (Invoking guix-package): Adjust `--search'
  documentation, and give an example.
master
Ludovic Courtès 2013-02-01 13:16:27 +01:00
parent aa92cf980c
commit 299112d36e
6 changed files with 188 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile.am
View File

@ -234,6 +234,7 @@ TESTS = \
tests/base32.scm \
tests/builders.scm \
tests/derivations.scm \
tests/ui.scm \
tests/utils.scm \
tests/build-utils.scm \
tests/packages.scm \

17
doc/guix.texi
View File

@ -546,10 +546,21 @@ availability of packages:
@item --search=@var{regexp}
@itemx -s @var{regexp}
List the available packages whose synopsis or description matches
@var{regexp}.
@var{regexp}. Print all the meta-data of matching packages in
@code{recutils} format (@pxref{Top, GNU recutils databases,, recutils,
GNU recutils manual}).
For each package, print the following items, separated by tabs: its
name, version, and the source location of its definition.
This allows specific fields to be extracted using the @command{recsel}
command, for instance:
@example
$ guix-package -s malloc | recsel -p name,version
name: glibc
version: 2.17
name: libgc
version: 7.2alpha6
@end example
@item --list-installed[=@var{regexp}]
@itemx -I [@var{regexp}]

6
guix-package.in
View File

@ -597,11 +597,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(('search regexp)
(let ((regexp (and regexp (make-regexp regexp))))
(for-each (lambda (p)
(format #t "~a\t~a\t~a~%"
(package-name p)
(package-version p)
(location->string (package-location p))))
(for-each (cute package->recutils <> (current-output-port))
(find-packages-by-description regexp))
#t))
(_ #f))))

102
guix/ui.scm
View File

@ -21,6 +21,9 @@
#:use-module (guix store)
#:use-module (guix config)
#:use-module (guix packages)
#:use-module ((guix licenses) #:select (license? license-name))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (ice-9 match)
@ -32,7 +35,10 @@
show-bug-report-information
call-with-error-handling
with-error-handling
location->string))
location->string
fill-paragraph
string->recutils
package->recutils))
;;; Commentary:
;;;
@ -110,4 +116,98 @@ General help using GNU software: <http://www.gnu.org/gethelp/>"))
(($ <location> file line column)
(format #f "~a:~a:~a" file line column))))
(define* (fill-paragraph str width #:optional (column 0))
"Fill STR such that each line contains at most WIDTH characters, assuming
that the first character is at COLUMN.
When STR contains a single line break surrounded by other characters, it is
converted to a space; sequences of more than one line break are preserved."
(define (maybe-break chr result)
(match result
((column newlines chars)
(case chr
((#\newline)
`(,column ,(+ 1 newlines) ,chars))
(else
(let ((chars (case newlines
((0) chars)
((1) (cons #\space chars))
(else
(append (make-list newlines #\newline) chars))))
(column (case newlines
((0) column)
((1) (+ 1 column))
(else 0))))
(let ((chars (cons chr chars))
(column (+ 1 column)))
(if (> column width)
(let*-values (((before after)
(break (cut eqv? #\space <>) chars))
((len)
(length before)))
(if (<= len width)
`(,len
0
,(if (null? after)
before
(append before (cons #\newline (cdr after)))))
`(,column 0 ,chars))) ; unbreakable
`(,column 0 ,chars)))))))))
(match (string-fold maybe-break
`(,column 0 ())
str)
((_ _ chars)
(list->string (reverse chars)))))
(define (string->recutils str)
"Return a version of STR where newlines have been replaced by newlines
followed by \"+ \", which makes for a valid multi-line field value in the
`recutils' syntax."
(list->string
(string-fold-right (lambda (chr result)
(if (eqv? chr #\newline)
(cons* chr #\+ #\space result)
(cons chr result)))
'()
str)))
(define* (package->recutils p port
#:optional (width (or (and=> (getenv "WIDTH")
string->number)
80)))
"Write to PORT a `recutils' record of package P, arranging to fit within
WIDTH columns."
(define (description->recutils str)
(let ((str (_ str)))
(string->recutils
(fill-paragraph str width
(string-length "description: ")))))
;; Note: Don't i18n field names so that people can post-process it.
(format port "name: ~a~%" (package-name p))
(format port "version: ~a~%" (package-version p))
(format port "location: ~a~%"
(or (and=> (package-location p) location->string)
(_ "unknown")))
(format port "home-page: ~a~%" (package-home-page p))
(format port "license: ~a~%"
(match (package-license p)
(((? license? licenses) ...)
(string-join (map license-name licenses)
", "))
((? license? license)
(license-name license))
(x
(_ "unknown"))))
(format port "synopsis: ~a~%"
(string-map (match-lambda
(#\newline #\space)
(chr chr))
(or (and=> (package-synopsis p) _)
"")))
(format port "description: ~a~%"
(and=> (package-description p) description->recutils))
(newline port))
;;; ui.scm ends here

2
tests/guix-package.sh
View File

@ -70,7 +70,7 @@ then
test "`guix-package -p "$profile" -I 'g.*e' | cut -f1`" = "guile-bootstrap"
# Search.
test "`guix-package -s "GNU Hello" | cut -f1`" = "hello"
test "`guix-package -s "GNU Hello" | grep ^name:`" = "name: hello"
test "`guix-package -s "n0t4r341p4ck4g3"`" = ""
# Remove a package.

70
tests/ui.scm 100644
View File

@ -0,0 +1,70 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 (test-ui)
#:use-module (guix ui)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-64))
;; Test the (guix ui) module.
(define %paragraph
"GNU Guile is an implementation of the Scheme programming language, with
support for many SRFIs, packaged for use in a wide variety of environments.
In addition to implementing the R5RS Scheme standard and a large subset of
R6RS, Guile includes a module system, full access to POSIX system calls,
networking support, multiple threads, dynamic linking, a foreign function call
interface, and powerful string processing.")
(test-begin "ui")
(test-assert "fill-paragraph"
(every (lambda (column)
(every (lambda (width)
(every (lambda (line)
(<= (string-length line) width))
(string-split (fill-paragraph %paragraph
width column)
#\newline)))
'(15 30 35 40 45 50 60 70 80 90 100)))
'(0 5)))
(test-assert "fill-paragraph, consecutive newlines"
(every (lambda (width)
(any (lambda (line)
(string-prefix? "When STR" line))
(string-split
(fill-paragraph (procedure-documentation fill-paragraph)
width)
#\newline)))
'(15 20 25 30 40 50 60)))
(test-equal "fill-paragraph, large unbreakable word"
'("Here is a" "very-very-long-word"
"and that's" "it.")
(string-split
(fill-paragraph "Here is a very-very-long-word and that's it."
10)
#\newline))
(test-end "ui")
(exit (= (test-runner-fail-count (test-runner-current)) 0))