123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246 |
- (define-module (guix build union)
- #:use-module (ice-9 match)
- #:use-module (ice-9 format)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-26)
- #:use-module (rnrs bytevectors)
- #:use-module (rnrs io ports)
- #:export (union-build
- warn-about-collision
- relative-file-name
- symlink-relative))
- (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 '()))
- (match (readdir dir)
- ((or "." "..")
- (loop files))
- ((? eof-object?)
- (closedir dir)
- (sort files string<?))
- (file
- (loop (cons file files)))))))
- (define (file-is-directory? file)
- (match (stat file #f)
- (#f #f)
- (st (eq? 'directory (stat:type st)))))
- (define (file=? file1 file2)
- "Return #t if FILE1 and FILE2 are regular files and their contents are
- identical, #f otherwise."
- (let ((st1 (stat file1 #f))
- (st2 (stat file2 #f)))
-
- (and st1 st2
- (or (= (stat:ino st1) (stat:ino st2))
- (and (eq? (stat:type st1) 'regular)
- (eq? (stat:type st2) 'regular)
- (= (stat:size st1) (stat:size st2))
- (call-with-input-file file1
- (lambda (port1)
- (call-with-input-file file2
- (lambda (port2)
- (define len 8192)
- (define buf1 (make-bytevector len))
- (define buf2 (make-bytevector len))
- (let loop ()
- (let ((n1 (get-bytevector-n! port1 buf1 0 len))
- (n2 (get-bytevector-n! port2 buf2 0 len)))
- (and (equal? n1 n2)
- (or (eof-object? n1)
- (loop))))))))))))))
- (define %harmless-collisions
-
-
-
-
-
- '("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)
- (symlink symlink)
- (resolve-collision warn-about-collision))
- "Build in the OUTPUT directory a symlink tree that is the union of all the
- 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)
- (symlink input output))
- (define (resolve-collisions output dirs files)
- (cond ((null? dirs)
-
- (match (resolve-collision files)
- (#f #f)
- ((? string? file)
- (symlink* file output))))
- (else
-
- (error "union-build: collision between file and directories"
- `((files ,files) (dirs ,dirs))))))
- (define (union output inputs)
- (match inputs
- ((input)
-
-
- (if (and create-all-directories? (file-is-directory? input))
- (union-of-directories output inputs)
- (symlink* input output)))
- (_
- (call-with-values (lambda () (partition file-is-directory? inputs))
- (match-lambda*
- ((dirs ())
-
- (union-of-directories output dirs))
- ((() (file (? (cut file=? <> file)) ...))
-
-
- (symlink* file output))
- ((dirs files)
- (resolve-collisions output dirs files)))))))
- (define (union-of-directories output dirs)
-
- (mkdir output)
-
-
- (let ((table (make-hash-table)))
- (define (add-to-table! file dir)
- (hash-set! table file (cons dir (hash-ref table file '()))))
-
- (for-each (lambda (dir)
- (for-each (cut add-to-table! <> dir)
- (files-in-directory dir)))
- dirs)
-
-
- (hash-for-each (lambda (file dirs-with-file)
- (union (string-append output "/" file)
- (map (cut string-append <> "/" file)
- (reverse dirs-with-file))))
- table)))
- (setvbuf (current-output-port) 'line)
- (setvbuf (current-error-port) 'line)
- (when (file-port? log-port)
- (setvbuf log-port 'line))
- (union-of-directories output (delete-duplicates inputs)))
- (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))
|