diff options
author | Marius Bakke <mbakke@fastmail.com> | 2020-05-08 21:40:51 +0200 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2020-05-08 21:40:51 +0200 |
commit | 4bdf4182fe080c3409f6ef9b410146b67cfa2595 (patch) | |
tree | f1123ddb8c57eda6de026982904f6c5309adaca6 /guix/store.scm | |
parent | c81457a5883ea43950eb2ecdcbb58a5b144bcd11 (diff) | |
parent | 23a59b180b28b9fa22120c2b8305b9324442b94d (diff) | |
download | guix-patches-4bdf4182fe080c3409f6ef9b410146b67cfa2595.tar guix-patches-4bdf4182fe080c3409f6ef9b410146b67cfa2595.tar.gz |
Merge branch 'core-updates'
Diffstat (limited to 'guix/store.scm')
-rw-r--r-- | guix/store.scm | 40 |
1 files changed, 40 insertions, 0 deletions
diff --git a/guix/store.scm b/guix/store.scm index fb4b92e0c4..6c7c07fd2d 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -103,6 +103,7 @@ add-text-to-store add-to-store add-file-tree-to-store + file-mapping->tree binary-file with-build-handler map/accumulate-builds @@ -1237,6 +1238,45 @@ an arbitrary directory layout in the store without creating a derivation." (hash-set! cache tree result) result))))) +(define (file-mapping->tree mapping) + "Convert MAPPING, an alist like: + + ((\"guix/build/utils.scm\" . \"…/utils.scm\")) + +to a tree suitable for 'add-file-tree-to-store' and 'interned-file-tree'." + (let ((mapping (map (match-lambda + ((destination . source) + (cons (string-tokenize destination %not-slash) + source))) + mapping))) + (fold (lambda (pair result) + (match pair + ((destination . source) + (let loop ((destination destination) + (result result)) + (match destination + ((file) + (let* ((mode (stat:mode (stat source))) + (type (if (zero? (logand mode #o100)) + 'regular + 'executable))) + (alist-cons file + `(,type (file ,source)) + result))) + ((file rest ...) + (let ((directory (assoc-ref result file))) + (alist-cons file + `(directory + ,@(loop rest + (match directory + (('directory . entries) entries) + (#f '())))) + (if directory + (alist-delete file result) + result))))))))) + '() + mapping))) + (define current-build-prompt ;; When true, this is the prompt to abort to when 'build-things' is called. (make-parameter #f)) |