ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 05:18:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

utils: 'current-source-directory' resolves relative file names at run time.

Browse source 
* guix/utils.scm (absolute-dirname): New procedure.
(current-source-directory): Emit code to use it instead of calling
'search-path'.
This commit is contained in:
Ludovic Courtès 2016-06-19 22:15:15 +02:00
parent 95fa173ed1
commit cbbbb7be0f
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 17 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
guix/utils.scm
View file

@ -702,6 +702,18 @@ (define (read! bv start n)
;;; Source location. ;;; Source location.
;;; ;;;
(define (absolute-dirname file)
"Return the absolute name of the directory containing FILE, or #f upon
failure."
(match (search-path %load-path file)
(#f #f)
((? string? file)
;; If there are relative names in %LOAD-PATH, FILE can be relative and
;; needs to be canonicalized.
(if (string-prefix? "/" file)
(dirname file)
(canonicalize-path (dirname file))))))
(define-syntax current-source-directory (define-syntax current-source-directory
(lambda (s) (lambda (s)
"Return the absolute name of the current directory, or #f if it could not "Return the absolute name of the current directory, or #f if it could not
@ -711,11 +723,13 @@ (define-syntax current-source-directory
(match (assq 'filename (syntax-source s)) (match (assq 'filename (syntax-source s))
(('filename . (? string? file-name)) (('filename . (? string? file-name))
;; If %FILE-PORT-NAME-CANONICALIZATION is 'relative, then FILE-NAME ;; If %FILE-PORT-NAME-CANONICALIZATION is 'relative, then FILE-NAME
;; can be relative. In that case, we try to find out the absolute ;; can be relative. In that case, we try to find out at run time
;; file name by looking at %LOAD-PATH. ;; the absolute file name by looking at %LOAD-PATH; doing this at
;; run time rather than expansion time is necessary to allow files
;; to be moved on the file system.
(if (string-prefix? "/" file-name) (if (string-prefix? "/" file-name)
(dirname file-name) (dirname file-name)
(and=> (search-path %load-path file-name) dirname))) #`(absolute-dirname #,file-name)))
(_ (_
#f)))))) #f))))))