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.

107 lines
3.9 KiB

  1. ;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
  2. ;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of Guix.
  5. ;;;
  6. ;;; Guix is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 3 of the License, or (at
  9. ;;; your option) any later version.
  10. ;;;
  11. ;;; Guix is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  14. ;;; GNU General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Guix. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (distro)
  19. #:use-module (guix packages)
  20. #:use-module (guix utils)
  21. #:use-module (ice-9 ftw)
  22. #:use-module (srfi srfi-1)
  23. #:use-module (srfi srfi-26)
  24. #:use-module (srfi srfi-39)
  25. #:export (search-patch
  26. %patch-directory
  27. find-packages-by-name))
  28. ;;; Commentary:
  29. ;;;
  30. ;;; General utilities for the software distribution---i.e., the modules under
  31. ;;; (distro ...).
  32. ;;;
  33. ;;; Code:
  34. (define _ (cut gettext <> "guix"))
  35. (define %patch-directory
  36. (make-parameter
  37. (or (getenv "DISTRO_PATCH_DIRECTORY")
  38. (compile-time-value (getenv "DISTRO_INSTALLED_PATCH_DIRECTORY")))))
  39. (define (search-patch file-name)
  40. "Search the patch FILE-NAME."
  41. (search-path (list (%patch-directory)) file-name))
  42. (define %distro-module-directory
  43. ;; Absolute path of the (distro ...) module root.
  44. (string-append (dirname (search-path %load-path "distro.scm"))
  45. "/distro/packages"))
  46. (define (package-files)
  47. "Return the list of files that implement distro modules."
  48. (define prefix-len
  49. (string-length (dirname (search-path %load-path "distro.scm"))))
  50. (file-system-fold (const #t) ; enter?
  51. (lambda (path stat result) ; leaf
  52. (if (string-suffix? ".scm" path)
  53. (cons (substring path prefix-len) result)
  54. result))
  55. (lambda (path stat result) ; down
  56. result)
  57. (lambda (path stat result) ; up
  58. result)
  59. (const #f) ; skip
  60. (lambda (path stat errno result)
  61. (format (current-error-port)
  62. (_ "warning: cannot access `~a': ~a~%")
  63. path (strerror errno))
  64. result)
  65. '()
  66. %distro-module-directory
  67. stat))
  68. (define (package-modules)
  69. "Return the list of modules that provide packages for the distribution."
  70. (define not-slash
  71. (char-set-complement (char-set #\/)))
  72. (filter-map (lambda (path)
  73. (let ((name (map string->symbol
  74. (string-tokenize (string-drop-right path 4)
  75. not-slash))))
  76. (false-if-exception (resolve-interface name))))
  77. (package-files)))
  78. (define* (find-packages-by-name name #:optional version)
  79. "Return the list of packages with the given NAME. If VERSION is not #f,
  80. then only return packages whose version is equal to VERSION."
  81. (define right-package?
  82. (if version
  83. (lambda (p)
  84. (and (package? p)
  85. (string=? (package-name p) name)
  86. (string=? (package-version p) version)))
  87. (lambda (p)
  88. (and (package? p)
  89. (string=? (package-name p) name)))))
  90. (append-map (lambda (module)
  91. (filter right-package?
  92. (module-map (lambda (sym var)
  93. (variable-ref var))
  94. module)))
  95. (package-modules)))