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.

171 lines
6.4 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-newest-available-packages))
  36. ;;; Commentary:
  37. ;;;
  38. ;;; General utilities for the software distribution---i.e., the modules under
  39. ;;; (gnu packages ...).
  40. ;;;
  41. ;;; Code:
  42. (define _ (cut gettext <> "guix"))
  43. ;; By default, we store patches and bootstrap binaries alongside Guile
  44. ;; modules. This is so that these extra files can be found without
  45. ;; requiring a special setup, such as a specific installation directory
  46. ;; and an extra environment variable. One advantage of this setup is
  47. ;; that everything just works in an auto-compilation setting.
  48. (define %patch-path
  49. (make-parameter
  50. (map (cut string-append <> "/gnu/packages/patches")
  51. %load-path)))
  52. (define %bootstrap-binaries-path
  53. (make-parameter
  54. (map (cut string-append <> "/gnu/packages/bootstrap")
  55. %load-path)))
  56. (define (search-patch file-name)
  57. "Search the patch FILE-NAME."
  58. (search-path (%patch-path) file-name))
  59. (define (search-bootstrap-binary file-name system)
  60. "Search the bootstrap binary FILE-NAME for SYSTEM."
  61. (search-path (%bootstrap-binaries-path)
  62. (string-append system "/" file-name)))
  63. (define %distro-module-directory
  64. ;; Absolute path of the (gnu packages ...) module root.
  65. (string-append (dirname (search-path %load-path "gnu/packages.scm"))
  66. "/packages"))
  67. (define (package-files)
  68. "Return the list of files that implement distro modules."
  69. (define prefix-len
  70. (string-length
  71. (dirname (dirname (search-path %load-path "gnu/packages.scm")))))
  72. (file-system-fold (const #t) ; enter?
  73. (lambda (path stat result) ; leaf
  74. (if (string-suffix? ".scm" path)
  75. (cons (substring path prefix-len) result)
  76. result))
  77. (lambda (path stat result) ; down
  78. result)
  79. (lambda (path stat result) ; up
  80. result)
  81. (const #f) ; skip
  82. (lambda (path stat errno result)
  83. (warning (_ "cannot access `~a': ~a~%")
  84. path (strerror errno))
  85. result)
  86. '()
  87. %distro-module-directory
  88. stat))
  89. (define (package-modules)
  90. "Return the list of modules that provide packages for the distribution."
  91. (define not-slash
  92. (char-set-complement (char-set #\/)))
  93. (filter-map (lambda (path)
  94. (let ((name (map string->symbol
  95. (string-tokenize (string-drop-right path 4)
  96. not-slash))))
  97. (false-if-exception (resolve-interface name))))
  98. (package-files)))
  99. (define (fold-packages proc init)
  100. "Call (PROC PACKAGE RESULT) for each available package, using INIT as
  101. the initial value of RESULT. It is guaranteed to never traverse the
  102. same package twice."
  103. (identity ; discard second return value
  104. (fold2 (lambda (module result seen)
  105. (fold2 (lambda (var result seen)
  106. (if (and (package? var)
  107. (not (vhash-assq var seen)))
  108. (values (proc var result)
  109. (vhash-consq var #t seen))
  110. (values result seen)))
  111. result
  112. seen
  113. (module-map (lambda (sym var)
  114. (false-if-exception (variable-ref var)))
  115. module)))
  116. init
  117. vlist-null
  118. (package-modules))))
  119. (define* (find-packages-by-name name #:optional version)
  120. "Return the list of packages with the given NAME. If VERSION is not #f,
  121. then only return packages whose version is equal to VERSION."
  122. (define right-package?
  123. (if version
  124. (lambda (p)
  125. (and (string=? (package-name p) name)
  126. (string=? (package-version p) version)))
  127. (lambda (p)
  128. (string=? (package-name p) name))))
  129. (fold-packages (lambda (package result)
  130. (if (right-package? package)
  131. (cons package result)
  132. result))
  133. '()))
  134. (define (find-newest-available-packages)
  135. "Return a vhash keyed by package names, and with
  136. associated values of the form
  137. (newest-version newest-package ...)
  138. where the preferred package is listed first."
  139. ;; FIXME: Currently, the preferred package is whichever one
  140. ;; was found last by 'fold-packages'. Find a better solution.
  141. (fold-packages (lambda (p r)
  142. (let ((name (package-name p))
  143. (version (package-version p)))
  144. (match (vhash-assoc name r)
  145. ((_ newest-so-far . pkgs)
  146. (case (version-compare version newest-so-far)
  147. ((>) (vhash-cons name `(,version ,p) r))
  148. ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
  149. ((<) r)))
  150. (#f (vhash-cons name `(,version ,p) r)))))
  151. vlist-null))