#!@BASH@
# -*- mode: scheme; coding: utf-8; -*-

# XXX: We have to go through Bash because there's no command-line switch to
# augment %load-compiled-path, and because of the silly 127-byte limit for
# the shebang line in Linux.
# Use `load-compiled' because `load' (and `-l') doesn't otherwise load our
# .go file (see <http://bugs.gnu.org/12519>).
# Unset 'GUILE_LOAD_COMPILED_PATH' to make sure we do not stumble upon
# incompatible .go files.  See
# <https://lists.gnu.org/archive/html/guile-devel/2016-03/msg00000.html>.

unset GUILE_LOAD_COMPILED_PATH
main="(@ (gnu build-support ld-wrapper) ld-wrapper)"
exec @GUILE@ -c "(load-compiled \"@SELF@.go\") (apply $main (cdr (command-line)))" "$@"
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 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 Genera</td></tr></table>
<table class='tabs'><tr><td>
<a class='active' href='/guix/about/'>about</a><a href='/guix/'>summary</a><a href='/guix/refs/?id=3e92082463d014befdbb5073074490c07377cde3'>refs</a><a href='/guix/log/'>log</a><a href='/guix/tree/?id=3e92082463d014befdbb5073074490c07377cde3'>tree</a><a href='/guix/commit/?id=3e92082463d014befdbb5073074490c07377cde3'>commit</a><a href='/guix/diff/?id=3e92082463d014befdbb5073074490c07377cde3'>diff</a></td><td class='form'><form class='right' method='get' action='/guix/log/'>
<input type='hidden' name='id' value='3e92082463d014befdbb5073074490c07377cde3'/><select name='qt'>
<option value='grep'>log msg</option>
<option value='author'>author</option>
<option value='committer'>committer</option>
<option value='range'>range</option>
</select>
<input class='txt' type='search' size='10' name='q' value=''/>
<input type='submit' value='search'/>
</form>
</td></tr></table>
<div class='content'><div id='summary'><pre>
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2024 Fabio Natali &lt;me@fabionatali.com&gt;
;;;
;;; 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 &lt;http://www.gnu.org/licenses/&gt;.

(define-module (gnu home services music)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (gnu home services)
  #:use-module (gnu packages music)
  #:use-module (gnu packages video)
  #:export (home-beets-configuration
            home-beets-service-type))

;;; Commentary:
;;;
;;; A Guix Home service to configure Beets, a music file and metadata manager.
;;;
;;; Code:

(define-record-type* &lt;home-beets-configuration&gt;
  home-beets-configuration make-home-beets-configuration
  home-beets-configuration?
  (package home-beets-package (default beets))
  (directory home-beets-directory (default #f))
  (extra-options home-beets-extra-options (default &apos;()))
  (extra-packages home-beets-extra-packages (default (list ffmpeg))))

(define (home-beets-configuration-&gt;file config)
  &quot;Return the Beets configuration file corresponding to CONFIG.&quot;
  (match-record config &lt;home-beets-configuration&gt;
    (directory extra-options)
    (plain-file &quot;beets.yaml&quot;
                (string-append &quot;directory: &quot; directory &quot;\n&quot;
                               (string-join extra-options &quot;\n&quot; &apos;suffix)))))

(define home-beets-service-type
  (service-type
   (name &apos;home-beets)
   (extensions
    (list
     (service-extension home-profile-service-type
                        (lambda (config)
                          (cons* (home-beets-package config)
                                 (home-beets-extra-packages config))))
     (service-extension home-xdg-configuration-files-service-type
                        (lambda (config)
                          (list `(&quot;beets/config.yaml&quot;
                                  ,(home-beets-configuration-&gt;file config)))))))
   (description &quot;Configure Beets, a music file and metadata manager.&quot;)))
</pre>
</div></div> <!-- class=content -->
                         <div class=footer>generated by
                             <a href="https://git.zx2c4.com/cgit/about/">
                                 cgit
                             </a>
                         </div>
                        </div> <!-- id=cgit -->
</body>
</html>
e-name? file)
  ;; Return #t when FILE is the name of a file either within the store
  ;; (possibly via a symlink) or within the build directory.
  (let ((file (readlink* file)))
    (or (not (string-prefix? "/" file))
        (string-prefix? %store-directory file)
        (string-prefix? %temporary-directory file)
        (and %build-directory
             (string-prefix? %build-directory file)))))

(define (store-file-name? file)
  ;; Return #t when FILE is a store file, possibly indirectly.
  (string-prefix? %store-directory (readlink* file)))

(define (shared-library? file)
  ;; Return #t when FILE denotes a shared library.
  (or (string-suffix? ".so" file)
      (let ((index (string-contains file ".so.")))
        ;; Since we cannot use regexps during bootstrap, roll our own.
        (and index
             (string-every (char-set-union (char-set #\.) char-set:digit)
                           (string-drop file (+ index 3)))))))

(define (library-search-path args)
  ;; Return the library search path as a list of directory names.  The GNU ld
  ;; manual notes that "[a]ll `-L' options apply to all `-l' options,
  ;; regardless of the order in which the options appear", so we must compute
  ;; the search path independently of the -l options.
  (let loop ((args args)
             (path '()))
    (match args
      (()
       (reverse path))
      (("-L" directory . rest)
       (loop rest (cons directory path)))
      ((argument . rest)
       (if (string-prefix? "-L" argument)         ;augment the search path
           (loop rest
                 (cons (string-drop argument 2) path))
           (loop rest path))))))

(define (library-files-linked args library-path)
  ;; Return the absolute file names of shared libraries explicitly linked
  ;; against via `-l' or with an absolute file name in ARGS, looking them up
  ;; in LIBRARY-PATH.
  (define files+args
    (fold (lambda (argument result)
            (match result
              ((library-files ((and flag
                                    (or "-dynamic-linker" "-plugin"))
                               . rest))
               ;; When passed '-dynamic-linker ld.so', ignore 'ld.so'; when
               ;; passed '-plugin liblto_plugin.so', ignore
               ;; 'liblto_plugin.so'.  See <http://bugs.gnu.org/20102>.
               (list library-files
                     (cons* argument flag rest)))
              ((library-files previous-args)
               (cond ((string-prefix? "-l" argument) ;add library
                      (let* ((lib  (string-append "lib"
                                                  (string-drop argument 2)
                                                  ".so"))
                             (full (search-path library-path lib)))
                        (list (if full
                                  (cons full library-files)
                                  library-files)
                              (cons argument previous-args))))
                     ((and (string-prefix? %store-directory argument)
                           (shared-library? argument)) ;add library
                      (list (cons argument library-files)
                            (cons argument previous-args)))
                     (else
                      (list library-files
                            (cons argument previous-args)))))))
          (list '() '())
          args))

  (match files+args
    ((files arguments)
     (reverse files))))

(define (rpath-arguments library-files)
  ;; Return the `-rpath' argument list for each of LIBRARY-FILES, a list of
  ;; absolute file names.
  (fold-right (lambda (file args)
                ;; Add '-rpath' if and only if FILE is in the store; we don't
                ;; want to add '-rpath' for files under %BUILD-DIRECTORY or
                ;; %TEMPORARY-DIRECTORY because that could leak to installed
                ;; files.
                (cond ((and (not %disable-rpath?)
                            (store-file-name? file))
                       (cons* "-rpath" (dirname file) args))
                      ((or %allow-impurities?
                           (pure-file-name? file))
                       args)
                      (else
                       (begin
                         (format (current-error-port)
                                 "ld-wrapper: error: attempt to use \
library outside of ~a: ~s~%"
                                 %store-directory file)
                         (exit 1)))))
              '()
              library-files))

(define (expand-arguments args)
  ;; Expand ARGS such that "response file" arguments, such as "@args.txt", are
  ;; expanded (info "(gcc) Overall Options").
  (define (response-file-arguments file)
    (when %debug?
      (format (current-error-port)
              "ld-wrapper: attempting to read arguments from '~a'~%" file))

    ;; FIXME: Options can contain whitespace if they are protected by single
    ;; or double quotes; this is not implemented here.
    (string-tokenize (call-with-input-file file read-string)))

  (define result
    (fold-right (lambda (arg result)
                  (if (string-prefix? "@" arg)
                      (let ((file (string-drop arg 1)))
                        (append (catch 'system-error
                                  (lambda ()
                                    (response-file-arguments file))
                                  (lambda args
                                    ;; FILE doesn't exist or cannot be read so
                                    ;; leave ARG as is.
                                    (list arg)))
                                result))
                      (cons arg result)))
                '()
                args))

  ;; If there are "@" arguments in RESULT *and* we can expand them (they don't
  ;; refer to nonexistent files), then recurse.
  (if (equal? result args)
      result
      (expand-arguments result)))

(define (ld-wrapper . args)
  ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches.
  (let* ((args (expand-arguments args))
         (path (library-search-path args))
         (libs (library-files-linked args path))
         (args (append args (rpath-arguments libs))))
    (when %debug?
      (format (current-error-port)
              "ld-wrapper: library search path: ~s~%" path)
      (format (current-error-port)
              "ld-wrapper: libraries linked: ~s~%" libs)
      (format (current-error-port)
              "ld-wrapper: invoking `~a' with ~s~%"
              %real-ld args)
      (force-output (current-error-port)))
    (apply execl %real-ld (basename %real-ld) args)))

;;; ld-wrapper.scm ends here