Mirror of GNU Guix
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

184 lines
6.9 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
  4. ;;;
  5. ;;; This file is part of GNU Guix.
  6. ;;;
  7. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  8. ;;; under the terms of the GNU General Public License as published by
  9. ;;; the Free Software Foundation; either version 3 of the License, or (at
  10. ;;; your option) any later version.
  11. ;;;
  12. ;;; GNU Guix is distributed in the hope that it will be useful, but
  13. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;;; GNU General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  19. (define-module (gnu packages)
  20. #:use-module (guix packages)
  21. #:use-module (guix ui)
  22. #:use-module (guix utils)
  23. #:use-module (ice-9 ftw)
  24. #:use-module (ice-9 vlist)
  25. #:use-module (ice-9 match)
  26. #:use-module (srfi srfi-1)
  27. #:use-module (srfi srfi-26)
  28. #:use-module (srfi srfi-39)
  29. #:export (search-patch
  30. search-bootstrap-binary
  31. %patch-directory
  32. %bootstrap-binaries-path
  33. fold-packages
  34. find-packages-by-name
  35. find-best-packages-by-name
  36. find-newest-available-packages))
  37. ;;; Commentary:
  38. ;;;
  39. ;;; General utilities for the software distribution---i.e., the modules under
  40. ;;; (gnu packages ...).
  41. ;;;
  42. ;;; Code:
  43. (define _ (cut gettext <> "guix"))
  44. ;; By default, we store patches and bootstrap binaries alongside Guile
  45. ;; modules. This is so that these extra files can be found without
  46. ;; requiring a special setup, such as a specific installation directory
  47. ;; and an extra environment variable. One advantage of this setup is
  48. ;; that everything just works in an auto-compilation setting.
  49. (define %patch-path
  50. (make-parameter
  51. (map (cut string-append <> "/gnu/packages/patches")
  52. %load-path)))
  53. (define %bootstrap-binaries-path
  54. (make-parameter
  55. (map (cut string-append <> "/gnu/packages/bootstrap")
  56. %load-path)))
  57. (define (search-patch file-name)
  58. "Search the patch FILE-NAME."
  59. (search-path (%patch-path) file-name))
  60. (define (search-bootstrap-binary file-name system)
  61. "Search the bootstrap binary FILE-NAME for SYSTEM."
  62. (search-path (%bootstrap-binaries-path)
  63. (string-append system "/" file-name)))
  64. (define %distro-module-directory
  65. ;; Absolute path of the (gnu packages ...) module root.
  66. (string-append (dirname (search-path %load-path "gnu/packages.scm"))
  67. "/packages"))
  68. (define (package-files)
  69. "Return the list of files that implement distro modules."
  70. (define prefix-len
  71. (string-length
  72. (dirname (dirname (search-path %load-path "gnu/packages.scm")))))
  73. (file-system-fold (const #t) ; enter?
  74. (lambda (path stat result) ; leaf
  75. (if (string-suffix? ".scm" path)
  76. (cons (substring path prefix-len) result)
  77. result))
  78. (lambda (path stat result) ; down
  79. result)
  80. (lambda (path stat result) ; up
  81. result)
  82. (const #f) ; skip
  83. (lambda (path stat errno result)
  84. (warning (_ "cannot access `~a': ~a~%")
  85. path (strerror errno))
  86. result)
  87. '()
  88. %distro-module-directory
  89. stat))
  90. (define (package-modules)
  91. "Return the list of modules that provide packages for the distribution."
  92. (define not-slash
  93. (char-set-complement (char-set #\/)))
  94. (filter-map (lambda (path)
  95. (let ((name (map string->symbol
  96. (string-tokenize (string-drop-right path 4)
  97. not-slash))))
  98. (false-if-exception (resolve-interface name))))
  99. (package-files)))
  100. (define (fold-packages proc init)
  101. "Call (PROC PACKAGE RESULT) for each available package, using INIT as
  102. the initial value of RESULT. It is guaranteed to never traverse the
  103. same package twice."
  104. (identity ; discard second return value
  105. (fold2 (lambda (module result seen)
  106. (fold2 (lambda (var result seen)
  107. (if (and (package? var)
  108. (not (vhash-assq var seen)))
  109. (values (proc var result)
  110. (vhash-consq var #t seen))
  111. (values result seen)))
  112. result
  113. seen
  114. (module-map (lambda (sym var)
  115. (false-if-exception (variable-ref var)))
  116. module)))
  117. init
  118. vlist-null
  119. (package-modules))))
  120. (define* (find-packages-by-name name #:optional version)
  121. "Return the list of packages with the given NAME. If VERSION is not #f,
  122. then only return packages whose version is equal to VERSION."
  123. (define right-package?
  124. (if version
  125. (lambda (p)
  126. (and (string=? (package-name p) name)
  127. (string=? (package-version p) version)))
  128. (lambda (p)
  129. (string=? (package-name p) name))))
  130. (fold-packages (lambda (package result)
  131. (if (right-package? package)
  132. (cons package result)
  133. result))
  134. '()))
  135. (define find-newest-available-packages
  136. (memoize
  137. (lambda ()
  138. "Return a vhash keyed by package names, and with
  139. associated values of the form
  140. (newest-version newest-package ...)
  141. where the preferred package is listed first."
  142. ;; FIXME: Currently, the preferred package is whichever one
  143. ;; was found last by 'fold-packages'. Find a better solution.
  144. (fold-packages (lambda (p r)
  145. (let ((name (package-name p))
  146. (version (package-version p)))
  147. (match (vhash-assoc name r)
  148. ((_ newest-so-far . pkgs)
  149. (case (version-compare version newest-so-far)
  150. ((>) (vhash-cons name `(,version ,p) r))
  151. ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
  152. ((<) r)))
  153. (#f (vhash-cons name `(,version ,p) r)))))
  154. vlist-null))))
  155. (define (find-best-packages-by-name name version)
  156. "If version is #f, return the list of packages named NAME with the highest
  157. version numbers; otherwise, return the list of packages named NAME and at
  158. VERSION."
  159. (if version
  160. (find-packages-by-name name version)
  161. (match (vhash-assoc name (find-newest-available-packages))
  162. ((_ version pkgs ...) pkgs)
  163. (#f '()))))