;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com>
;;;
#:use-module (srfi srfi-26)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
- #:export (union-build))
+ #:export (union-build
+
+ warn-about-collision
+
+ relative-file-name
+ symlink-relative))
;;; Commentary:
;;;
;;;
;;; Code:
+;; This code can be used with the bootstrap Guile, which is Guile 2.0, so
+;; provide a compatibility layer.
+(cond-expand
+ ((and guile-2 (not guile-2.2))
+ (define (setvbuf port mode . rest)
+ (apply (@ (guile) setvbuf) port
+ (match mode
+ ('line _IOLBF)
+ ('block _IOFBF)
+ ('none _IONBF))
+ rest)))
+ (else #f))
+
(define (files-in-directory dirname)
(let ((dir (opendir dirname)))
(let loop ((files '()))
(or (eof-object? n1)
(loop))))))))))))))
+(define %harmless-collisions
+ ;; This is a list of files that are known to collide, but for which emitting
+ ;; a warning doesn't make sense. For example, "icon-theme.cache" is
+ ;; regenerated by a profile hook which shadows the file provided by
+ ;; individual packages, and "gschemas.compiled" is made available to
+ ;; applications via 'glib-or-gtk-build-system'.
+ '("icon-theme.cache" "gschemas.compiled"))
+
+(define (warn-about-collision files)
+ "Handle the collision among FILES by emitting a warning and choosing the
+first one of THEM."
+ (let ((file (first files)))
+ (unless (member (basename file) %harmless-collisions)
+ (format (current-error-port)
+ "~%warning: collision encountered:~%~{ ~a~%~}"
+ files)
+ (format (current-error-port) "warning: choosing ~a~%" file))
+ file))
+
(define* (union-build output inputs
#:key (log-port (current-error-port))
- (create-all-directories? #f))
+ (create-all-directories? #f)
+ (symlink symlink)
+ (resolve-collision warn-about-collision))
"Build in the OUTPUT directory a symlink tree that is the union of all the
-INPUTS. As a special case, if CREATE-ALL-DIRECTORIES?, creates the
-subdirectories in the output directory to make sure the caller can modify them
-later."
+INPUTS, using SYMLINK to create symlinks. As a special case, if
+CREATE-ALL-DIRECTORIES?, creates the subdirectories in the output directory to
+make sure the caller can modify them later.
+
+When two or more regular files collide, call RESOLVE-COLLISION with the list
+of colliding files and use the one that it returns; or, if RESOLVE-COLLISION
+returns #f, skip the faulty file altogether."
(define (symlink* input output)
(format log-port "`~a' ~~> `~a'~%" input output)
(define (resolve-collisions output dirs files)
(cond ((null? dirs)
;; The inputs are all files.
- (format (current-error-port)
- "warning: collision encountered: ~{~a ~}~%"
- files)
-
- (let ((file (first files)))
- ;; TODO: Implement smarter strategies.
- (format (current-error-port)
- "warning: arbitrarily choosing ~a~%"
- file)
-
- (symlink* file output)))
+ (match (resolve-collision files)
+ (#f #f)
+ ((? string? file)
+ (symlink* file output))))
(else
;; The inputs are a mixture of files and directories
(reverse dirs-with-file))))
table)))
- (setvbuf (current-output-port) _IOLBF)
- (setvbuf (current-error-port) _IOLBF)
+ (setvbuf (current-output-port) 'line)
+ (setvbuf (current-error-port) 'line)
(when (file-port? log-port)
- (setvbuf log-port _IOLBF))
+ (setvbuf log-port 'line))
(union-of-directories output (delete-duplicates inputs)))
+\f
+;;;
+;;; Relative symlinks.
+;;;
+
+(define %not-slash
+ (char-set-complement (char-set #\/)))
+
+(define (relative-file-name reference file)
+ "Given REFERENCE and FILE, both of which are absolute file names, return the
+file name of FILE relative to REFERENCE.
+
+ (relative-file-name \"/gnu/store/foo\" \"/gnu/store/bin/bar\")
+ => \"../bin/bar\"
+
+Note that this is from a purely lexical standpoint; conversely, \"..\" is
+*not* resolved lexically on POSIX in the presence of symlinks."
+ (if (and (string-prefix? "/" file) (string-prefix? "/" reference))
+ (let loop ((reference (string-tokenize reference %not-slash))
+ (file (string-tokenize file %not-slash)))
+ (define (finish)
+ (string-join (append (make-list (length reference) "..") file)
+ "/"))
+
+ (match reference
+ (()
+ (finish))
+ ((head . tail)
+ (match file
+ (()
+ (finish))
+ ((head* . tail*)
+ (if (string=? head head*)
+ (loop tail tail*)
+ (finish)))))))
+ file))
+
+(define (symlink-relative old new)
+ "Assuming both OLD and NEW are absolute file names, make NEW a symlink to
+OLD, but using a relative file name."
+ (symlink (relative-file-name (dirname new) old)
+ new))
+
;;; union.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff