mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-02-11 06:20:18 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

gexp: Move 'file-mapping->tree' to (guix store).

Browse source 
* guix/gexp.scm (%not-slash): Remove.
(file-mapping->tree): Move to...
* guix/store.scm (file-mapping->tree): ... here.
This commit is contained in:
Ludovic Courtès 2020-01-30 01:17:54 +01:00
parent ac841750a5
commit 68dbd5c9de
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 40 additions and 43 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

43
guix/gexp.scm
View file

@ -1239,49 +1239,6 @@ execution environment."
;;; Module handling. ;;; Module handling.
;;; ;;;
(define %not-slash
(char-set-complement (char-set #\/)))
(define (file-mapping->tree mapping)
"Convert MAPPING, an alist like:
((\"guix/build/utils.scm\" . \"…/utils.scm\"))
to a tree suitable for '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 %utils-module (define %utils-module
;; This file provides 'mkdir-p', needed to implement 'imported-files' and ;; This file provides 'mkdir-p', needed to implement 'imported-files' and
;; other primitives below. Note: We give the file name relative to this ;; other primitives below. Note: We give the file name relative to this

40
guix/store.scm
View file

@ -103,6 +103,7 @@
add-text-to-store add-text-to-store
add-to-store add-to-store
add-file-tree-to-store add-file-tree-to-store
file-mapping->tree
binary-file binary-file
build-things build-things
build build
@ -1220,6 +1221,45 @@ an arbitrary directory layout in the store without creating a derivation."
(hash-set! cache tree result) (hash-set! cache tree result)
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 build-things (define build-things
(let ((build (operation (build-things (string-list things) (let ((build (operation (build-things (string-list things)
(integer mode)) (integer mode))