gnu: antlr2: Minor stylistic changes.
[jackhill/guix/guix.git] / guix / utils.scm
CommitLineData
233e7676 1;;; GNU Guix --- Functional package management for GNU
aa042770 2;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
3f00ff8b 3;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org>
516e3b6f 4;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
29a7c98a 5;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net>
1b846da8 6;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
bbd00d20 7;;; Copyright © 2015 David Thompson <davet@gnu.org>
63102406 8;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
e3deeebb 9;;;
233e7676 10;;; This file is part of GNU Guix.
e3deeebb 11;;;
233e7676 12;;; GNU Guix is free software; you can redistribute it and/or modify it
e3deeebb
LC
13;;; under the terms of the GNU General Public License as published by
14;;; the Free Software Foundation; either version 3 of the License, or (at
15;;; your option) any later version.
16;;;
233e7676 17;;; GNU Guix is distributed in the hope that it will be useful, but
e3deeebb
LC
18;;; WITHOUT ANY WARRANTY; without even the implied warranty of
19;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;;; GNU General Public License for more details.
21;;;
22;;; You should have received a copy of the GNU General Public License
233e7676 23;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
e3deeebb
LC
24
25(define-module (guix utils)
00e219d1 26 #:use-module (guix config)
38b3122a 27 #:use-module (srfi srfi-1)
72d86963 28 #:use-module (srfi srfi-9)
01ac19dc 29 #:use-module (srfi srfi-11)
38b3122a 30 #:use-module (srfi srfi-26)
de4c3f26 31 #:use-module (srfi srfi-39)
2535635f 32 #:use-module (ice-9 binary-ports)
31044751 33 #:autoload (rnrs io ports) (make-custom-binary-input-port)
c8be6f0d 34 #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
f9704f17 35 #:use-module (guix memoization)
1b846da8 36 #:use-module ((guix build utils) #:select (dump-port))
1752a17a 37 #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
38b3122a 38 #:use-module (ice-9 format)
de4c3f26
LC
39 #:autoload (ice-9 popen) (open-pipe*)
40 #:autoload (ice-9 rdelim) (read-line)
98090557 41 #:use-module (ice-9 regex)
72d86963 42 #:use-module (ice-9 match)
8ef3401f 43 #:use-module (ice-9 format)
31044751 44 #:use-module ((ice-9 iconv) #:prefix iconv:)
2cd5c038 45 #:use-module (system foreign)
19e1d5f7 46 #:re-export (memoize) ; for backwards compatibility
4c0c4db0 47 #:export (strip-keyword-arguments
0af2c24e
LC
48 default-keyword-arguments
49 substitute-keyword-arguments
6071122b 50 ensure-keyword-arguments
ff352cfb 51
07c8a98c
LC
52 current-source-directory
53
64fc89b6 54 <location>
ff352cfb
LC
55 location
56 location?
57 location-file
58 location-line
59 location-column
60 source-properties->location
f7df1e3e 61 location->source-properties
ff352cfb 62
8eb80484 63 nix-system->gnu-triplet
98090557 64 gnu-triplet->nix-system
9b48fb88 65 %current-system
9c1edabd 66 %current-target-system
1b846da8 67 package-name->name+version
cba36e64 68 target-mingw?
0d1e6ce4
MW
69 version-compare
70 version>?
cde1e967 71 version>=?
29a7c98a
ID
72 version-prefix
73 version-major+minor
7db3ff4a 74 guile-version>?
56b943de 75 string-replace-substring
16eb115e 76 arguments-from-environment-variable
0fdd3bea 77 file-extension
ac10e0e1 78 file-sans-extension
089b1678 79 compressed-file?
3bb168b0 80 switch-symlinks
861693f3 81 call-with-temporary-output-file
db6e5e2b 82 call-with-temporary-directory
04d4c8a4 83 with-atomic-file-output
739ab68b 84 cache-directory
d50cb56d 85 readlink*
50a3d594 86 edit-expression
7a8024a3
LC
87
88 filtered-port
89 compressed-port
80dea563 90 decompressed-port
01ac19dc
LC
91 call-with-decompressed-port
92 compressed-output-port
c8be6f0d
FB
93 call-with-compressed-output-port
94 canonical-newline-port))
e3deeebb 95
38b3122a 96\f
e0fbbc88
LC
97;;;
98;;; Filtering & pipes.
99;;;
100
101(define (filtered-port command input)
102 "Return an input port where data drained from INPUT is filtered through
103COMMAND (a list). In addition, return a list of PIDs that the caller must
101d9f3f
LC
104wait. When INPUT is a file port, it must be unbuffered; otherwise, any
105buffered data is lost."
e0fbbc88 106 (let loop ((input input)
443eb4e9 107 (pids '()))
e0fbbc88
LC
108 (if (file-port? input)
109 (match (pipe)
110 ((in . out)
111 (match (primitive-fork)
112 (0
443eb4e9
LC
113 (dynamic-wind
114 (const #f)
115 (lambda ()
116 (close-port in)
117 (close-port (current-input-port))
118 (dup2 (fileno input) 0)
119 (close-port (current-output-port))
120 (dup2 (fileno out) 1)
121 (catch 'system-error
122 (lambda ()
123 (apply execl (car command) command))
124 (lambda args
125 (format (current-error-port)
126 "filtered-port: failed to execute '~{~a ~}': ~a~%"
127 command (strerror (system-error-errno args))))))
128 (lambda ()
129 (primitive-_exit 1))))
e0fbbc88
LC
130 (child
131 (close-port out)
132 (values in (cons child pids))))))
133
134 ;; INPUT is not a file port, so fork just for the sake of tunneling it
135 ;; through a file port.
136 (match (pipe)
137 ((in . out)
138 (match (primitive-fork)
139 (0
140 (dynamic-wind
141 (const #t)
142 (lambda ()
143 (close-port in)
144 (dump-port input out))
145 (lambda ()
146 (false-if-exception (close out))
443eb4e9 147 (primitive-_exit 0))))
e0fbbc88
LC
148 (child
149 (close-port out)
150 (loop in (cons child pids)))))))))
151
7a8024a3
LC
152(define (decompressed-port compression input)
153 "Return an input port where INPUT is decompressed according to COMPRESSION,
154a symbol such as 'xz."
155 (match compression
156 ((or #f 'none) (values input '()))
157 ('bzip2 (filtered-port `(,%bzip2 "-dc") input))
6c17422e 158 ('xz (filtered-port `(,%xz "-dc" "-T0") input))
7a8024a3
LC
159 ('gzip (filtered-port `(,%gzip "-dc") input))
160 (else (error "unsupported compression scheme" compression))))
161
162(define (compressed-port compression input)
163 "Return an input port where INPUT is decompressed according to COMPRESSION,
164a symbol such as 'xz."
165 (match compression
166 ((or #f 'none) (values input '()))
167 ('bzip2 (filtered-port `(,%bzip2 "-c") input))
6c17422e 168 ('xz (filtered-port `(,%xz "-c" "-T0") input))
7a8024a3
LC
169 ('gzip (filtered-port `(,%gzip "-c") input))
170 (else (error "unsupported compression scheme" compression))))
171
01ac19dc
LC
172(define (call-with-decompressed-port compression port proc)
173 "Call PROC with a wrapper around PORT, a file port, that decompresses data
30ce8012 174read from PORT according to COMPRESSION, a symbol such as 'xz."
01ac19dc
LC
175 (let-values (((decompressed pids)
176 (decompressed-port compression port)))
177 (dynamic-wind
178 (const #f)
179 (lambda ()
01ac19dc
LC
180 (proc decompressed))
181 (lambda ()
182 (close-port decompressed)
183 (unless (every (compose zero? cdr waitpid) pids)
184 (error "decompressed-port failure" pids))))))
185
80dea563
LC
186(define (filtered-output-port command output)
187 "Return an output port. Data written to that port is filtered through
188COMMAND and written to OUTPUT, an output file port. In addition, return a
189list of PIDs to wait for. OUTPUT must be unbuffered; otherwise, any buffered
190data is lost."
191 (match (pipe)
192 ((in . out)
193 (match (primitive-fork)
194 (0
195 (dynamic-wind
196 (const #f)
197 (lambda ()
198 (close-port out)
199 (close-port (current-input-port))
200 (dup2 (fileno in) 0)
201 (close-port (current-output-port))
202 (dup2 (fileno output) 1)
203 (catch 'system-error
204 (lambda ()
205 (apply execl (car command) command))
206 (lambda args
207 (format (current-error-port)
208 "filtered-output-port: failed to execute '~{~a ~}': ~a~%"
209 command (strerror (system-error-errno args))))))
210 (lambda ()
211 (primitive-_exit 1))))
212 (child
213 (close-port in)
214 (values out (list child)))))))
215
62d2b571
LC
216(define* (compressed-output-port compression output
217 #:key (options '()))
80dea563
LC
218 "Return an output port whose input is compressed according to COMPRESSION,
219a symbol such as 'xz, and then written to OUTPUT. In addition return a list
62d2b571
LC
220of PIDs to wait for. OPTIONS is a list of strings passed to the compression
221program--e.g., '(\"--fast\")."
80dea563
LC
222 (match compression
223 ((or #f 'none) (values output '()))
62d2b571 224 ('bzip2 (filtered-output-port `(,%bzip2 "-c" ,@options) output))
6c17422e 225 ('xz (filtered-output-port `(,%xz "-c" "-T0" ,@options) output))
62d2b571 226 ('gzip (filtered-output-port `(,%gzip "-c" ,@options) output))
80dea563
LC
227 (else (error "unsupported compression scheme" compression))))
228
62d2b571
LC
229(define* (call-with-compressed-output-port compression port proc
230 #:key (options '()))
01ac19dc 231 "Call PROC with a wrapper around PORT, a file port, that compresses data
62d2b571
LC
232that goes to PORT according to COMPRESSION, a symbol such as 'xz. OPTIONS is
233a list of command-line arguments passed to the compression program."
01ac19dc 234 (let-values (((compressed pids)
62d2b571
LC
235 (compressed-output-port compression port
236 #:options options)))
01ac19dc
LC
237 (dynamic-wind
238 (const #f)
239 (lambda ()
01ac19dc
LC
240 (proc compressed))
241 (lambda ()
242 (close-port compressed)
243 (unless (every (compose zero? cdr waitpid) pids)
244 (error "compressed-output-port failure" pids))))))
245
50a3d594
SB
246(define* (edit-expression source-properties proc #:key (encoding "UTF-8"))
247 "Edit the expression specified by SOURCE-PROPERTIES using PROC, which should
248be a procedure that takes the original expression in string and returns a new
249one. ENCODING will be used to interpret all port I/O, it default to UTF-8.
250This procedure returns #t on success."
251 (with-fluids ((%default-port-encoding encoding))
252 (let* ((file (assq-ref source-properties 'filename))
253 (line (assq-ref source-properties 'line))
254 (column (assq-ref source-properties 'column))
255 (in (open-input-file file))
256 ;; The start byte position of the expression.
257 (start (begin (while (not (and (= line (port-line in))
258 (= column (port-column in))))
259 (when (eof-object? (read-char in))
260 (error (format #f "~a: end of file~%" in))))
261 (ftell in)))
262 ;; The end byte position of the expression.
263 (end (begin (read in) (ftell in))))
264 (seek in 0 SEEK_SET) ; read from the beginning of the file.
265 (let* ((pre-bv (get-bytevector-n in start))
266 ;; The expression in string form.
31044751 267 (str (iconv:bytevector->string
50a3d594
SB
268 (get-bytevector-n in (- end start))
269 (port-encoding in)))
270 (post-bv (get-bytevector-all in))
271 (str* (proc str)))
272 ;; Verify the edited expression is still a scheme expression.
273 (call-with-input-string str* read)
274 ;; Update the file with edited expression.
275 (with-atomic-file-output file
276 (lambda (out)
277 (put-bytevector out pre-bv)
278 (display str* out)
279 ;; post-bv maybe the end-of-file object.
280 (when (not (eof-object? post-bv))
281 (put-bytevector out post-bv))
282 #t))))))
283
e0fbbc88 284\f
de4c3f26 285;;;
958dd3ce 286;;; Keyword arguments.
de4c3f26
LC
287;;;
288
5e110382
LC
289(define (strip-keyword-arguments keywords args)
290 "Remove all of the keyword arguments listed in KEYWORDS from ARGS."
291 (let loop ((args args)
292 (result '()))
293 (match args
294 (()
295 (reverse result))
296 (((? keyword? kw) arg . rest)
297 (loop rest
298 (if (memq kw keywords)
299 result
300 (cons* arg kw result))))
301 ((head . tail)
302 (loop tail (cons head result))))))
303
0af2c24e
LC
304(define (default-keyword-arguments args defaults)
305 "Return ARGS augmented with any keyword/value from DEFAULTS for
306keywords not already present in ARGS."
307 (let loop ((defaults defaults)
308 (args args))
309 (match defaults
310 ((kw value rest ...)
311 (loop rest
347df601 312 (if (memq kw args)
0af2c24e
LC
313 args
314 (cons* kw value args))))
315 (()
316 args))))
317
b8b129eb
EB
318(define-syntax collect-default-args
319 (syntax-rules ()
320 ((_)
321 '())
322 ((_ (_ _) rest ...)
323 (collect-default-args rest ...))
324 ((_ (kw _ dflt) rest ...)
325 (cons* kw dflt (collect-default-args rest ...)))))
326
0af2c24e
LC
327(define-syntax substitute-keyword-arguments
328 (syntax-rules ()
329 "Return a new list of arguments where the value for keyword arg KW is
b8b129eb
EB
330replaced by EXP. EXP is evaluated in a context where VAR is bound to the
331previous value of the keyword argument, or DFLT if given."
332 ((_ original-args ((kw var dflt ...) exp) ...)
333 (let loop ((args (default-keyword-arguments
334 original-args
335 (collect-default-args (kw var dflt ...) ...)))
0af2c24e
LC
336 (before '()))
337 (match args
338 ((kw var rest (... ...))
339 (loop rest (cons* exp kw before)))
340 ...
341 ((x rest (... ...))
342 (loop rest (cons x before)))
343 (()
344 (reverse before)))))))
345
6071122b
LC
346(define (delkw kw lst)
347 "Remove KW and its associated value from LST, a keyword/value list such
348as '(#:foo 1 #:bar 2)."
349 (let loop ((lst lst)
350 (result '()))
351 (match lst
352 (()
353 (reverse result))
354 ((kw? value rest ...)
355 (if (eq? kw? kw)
356 (append (reverse result) rest)
357 (loop rest (cons* value kw? result)))))))
358
359(define (ensure-keyword-arguments args kw/values)
360 "Force the keywords arguments KW/VALUES in the keyword argument list ARGS.
361For instance:
362
363 (ensure-keyword-arguments '(#:foo 2) '(#:foo 2))
364 => (#:foo 2)
365
366 (ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
367 => (#:foo 2 #:bar 3)
368
369 (ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))
370 => (#:foo 42 #:bar 3)
371"
372 (let loop ((args args)
373 (kw/values kw/values)
374 (result '()))
375 (match args
376 (()
377 (append (reverse result) kw/values))
378 ((kw value rest ...)
379 (match (memq kw kw/values)
380 ((_ value . _)
381 (loop rest (delkw kw kw/values) (cons* value kw result)))
382 (#f
383 (loop rest kw/values (cons* value kw result))))))))
384
958dd3ce
LC
385\f
386;;;
387;;; System strings.
388;;;
389
8eb80484
MW
390(define* (nix-system->gnu-triplet
391 #:optional (system (%current-system)) (vendor "unknown"))
392 "Return a guess of the GNU triplet corresponding to Nix system
393identifier SYSTEM."
3f00ff8b
MW
394 (match system
395 ("armhf-linux"
396 (string-append "arm-" vendor "-linux-gnueabihf"))
397 (_
398 (let* ((dash (string-index system #\-))
399 (arch (substring system 0 dash))
400 (os (substring system (+ 1 dash))))
401 (string-append arch
402 "-" vendor "-"
403 (if (string=? os "linux")
404 "linux-gnu"
405 os))))))
8eb80484 406
98090557
LC
407(define (gnu-triplet->nix-system triplet)
408 "Return the Nix system type corresponding to TRIPLET, a GNU triplet as
409returned by `config.guess'."
410 (let ((triplet (cond ((string-match "^i[345]86-(.*)$" triplet)
411 =>
412 (lambda (m)
413 (string-append "i686-" (match:substring m 1))))
414 (else triplet))))
3f00ff8b
MW
415 (cond ((string-match "^arm[^-]*-([^-]+-)?linux-gnueabihf" triplet)
416 "armhf-linux")
417 ((string-match "^([^-]+)-([^-]+-)?linux-gnu.*" triplet)
98090557
LC
418 =>
419 (lambda (m)
420 ;; Nix omits `-gnu' for GNU/Linux.
421 (string-append (match:substring m 1) "-linux")))
422 ((string-match "^([^-]+)-([^-]+-)?([[:alpha:]]+)([0-9]+\\.?)*$" triplet)
423 =>
424 (lambda (m)
425 ;; Nix strip the version number from names such as `gnu0.3',
426 ;; `darwin10.2.0', etc., and always strips the vendor part.
427 (string-append (match:substring m 1) "-"
428 (match:substring m 3))))
429 (else triplet))))
430
431(define %current-system
432 ;; System type as expected by Nix, usually ARCHITECTURE-KERNEL.
d8eea3d2
LC
433 ;; By default, this is equal to (gnu-triplet->nix-system %host-type).
434 (make-parameter %system))
ff352cfb 435
9c1edabd
LC
436(define %current-target-system
437 ;; Either #f or a GNU triplet representing the target system we are
438 ;; cross-building to.
439 (make-parameter #f))
440
aa042770
LC
441(define* (package-name->name+version spec
442 #:optional (delimiter #\@))
1b846da8
ML
443 "Given SPEC, a package name like \"foo@0.9.1b\", return two values: \"foo\"
444and \"0.9.1b\". When the version part is unavailable, SPEC and #f are
aa042770
LC
445returned. Both parts must not contain any '@'. Optionally, DELIMITER can be
446a character other than '@'."
447 (match (string-rindex spec delimiter)
1b846da8
ML
448 (#f (values spec #f))
449 (idx (values (substring spec 0 idx)
450 (substring spec (1+ idx))))))
451
cba36e64
JN
452(define* (target-mingw? #:optional (target (%current-target-system)))
453 (and target
454 (string-suffix? "-mingw32" target)))
455
0d1e6ce4
MW
456(define version-compare
457 (let ((strverscmp
458 (let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
459 (error "could not find `strverscmp' (from GNU libc)"))))
460 (pointer->procedure int sym (list '* '*)))))
461 (lambda (a b)
462 "Return '> when A denotes a newer version than B,
463'< when A denotes a older version than B,
464or '= when they denote equal versions."
465 (let ((result (strverscmp (string->pointer a) (string->pointer b))))
466 (cond ((positive? result) '>)
467 ((negative? result) '<)
468 (else '=))))))
469
29a7c98a
ID
470(define (version-prefix version-string num-parts)
471 "Truncate version-string to the first num-parts components of the version.
472For example, (version-prefix \"2.1.47.4.23\" 3) returns \"2.1.47\""
473 (string-join (take (string-split version-string #\.) num-parts) "."))
474
475
476(define (version-major+minor version-string)
477 "Return \"<major>.<minor>\", where major and minor are the major and
478minor version numbers from version-string."
479 (version-prefix version-string 2))
480
0d1e6ce4 481(define (version>? a b)
cde1e967 482 "Return #t when A denotes a version strictly newer than B."
0d1e6ce4
MW
483 (eq? '> (version-compare a b)))
484
cde1e967
LC
485(define (version>=? a b)
486 "Return #t when A denotes a version newer or equal to B."
487 (case (version-compare a b)
488 ((> =) #t)
489 (else #f)))
490
7db3ff4a
LC
491(define (guile-version>? str)
492 "Return #t if the running Guile version is greater than STR."
493 ;; Note: Using (version>? (version) "2.0.5") or similar doesn't work,
494 ;; because the result of (version) can have a prefix, like "2.0.5-deb1".
495 (version>? (string-append (major-version) "."
496 (minor-version) "."
497 (micro-version))
498 str))
499
0fdd3bea
LC
500(define (file-extension file)
501 "Return the extension of FILE or #f if there is none."
502 (let ((dot (string-rindex file #\.)))
503 (and dot (substring file (+ 1 dot) (string-length file)))))
504
ac10e0e1
LC
505(define (file-sans-extension file)
506 "Return the substring of FILE without its extension, if any."
507 (let ((dot (string-rindex file #\.)))
508 (if dot
509 (substring file 0 dot)
510 file)))
511
089b1678
LC
512(define (compressed-file? file)
513 "Return true if FILE denotes a compressed file."
514 (->bool (member (file-extension file)
515 '("gz" "bz2" "xz" "lz" "tgz" "tbz2" "zip"))))
516
3bb168b0
LC
517(define (switch-symlinks link target)
518 "Atomically switch LINK, a symbolic link, to point to TARGET. Works
519both when LINK already exists and when it does not."
520 (let ((pivot (string-append link ".new")))
521 (symlink target pivot)
522 (rename-file pivot link)))
523
56b943de
LC
524(define* (string-replace-substring str substr replacement
525 #:optional
526 (start 0)
527 (end (string-length str)))
528 "Replace all occurrences of SUBSTR in the START--END range of STR by
529REPLACEMENT."
530 (match (string-length substr)
531 (0
532 (error "string-replace-substring: empty substring"))
533 (substr-length
534 (let loop ((start start)
535 (pieces (list (substring str 0 start))))
536 (match (string-contains str substr start end)
537 (#f
538 (string-concatenate-reverse
539 (cons (substring str start) pieces)))
540 (index
541 (loop (+ index substr-length)
542 (cons* replacement
543 (substring str start index)
544 pieces))))))))
545
16eb115e
DP
546(define (arguments-from-environment-variable variable)
547 "Retrieve value of environment variable denoted by string VARIABLE in the
548form of a list of strings (`char-set:graphic' tokens) suitable for consumption
549by `args-fold', if VARIABLE is defined, otherwise return an empty list."
550 (let ((env (getenv variable)))
551 (if env
552 (string-tokenize env char-set:graphic)
553 '())))
554
861693f3
LC
555(define (call-with-temporary-output-file proc)
556 "Call PROC with a name of a temporary file and open output port to that
557file; close the file and delete it when leaving the dynamic extent of this
558call."
57db49cc
LC
559 (let* ((directory (or (getenv "TMPDIR") "/tmp"))
560 (template (string-append directory "/guix-file.XXXXXX"))
561 (out (mkstemp! template)))
861693f3
LC
562 (dynamic-wind
563 (lambda ()
564 #t)
565 (lambda ()
566 (proc template out))
567 (lambda ()
568 (false-if-exception (close out))
569 (false-if-exception (delete-file template))))))
04d4c8a4 570
db6e5e2b
DT
571(define (call-with-temporary-directory proc)
572 "Call PROC with a name of a temporary directory; close the directory and
573delete it when leaving the dynamic extent of this call."
574 (let* ((directory (or (getenv "TMPDIR") "/tmp"))
575 (template (string-append directory "/guix-directory.XXXXXX"))
576 (tmp-dir (mkdtemp! template)))
577 (dynamic-wind
578 (const #t)
579 (lambda ()
580 (proc tmp-dir))
581 (lambda ()
582 (false-if-exception (rmdir tmp-dir))))))
583
04d4c8a4
LC
584(define (with-atomic-file-output file proc)
585 "Call PROC with an output port for the file that is going to replace FILE.
586Upon success, FILE is atomically replaced by what has been written to the
587output port, and PROC's result is returned."
588 (let* ((template (string-append file ".XXXXXX"))
589 (out (mkstemp! template)))
590 (with-throw-handler #t
591 (lambda ()
592 (let ((result (proc out)))
1752a17a
LC
593 (fdatasync out)
594 (close-port out)
04d4c8a4
LC
595 (rename-file template file)
596 result))
597 (lambda (key . args)
c25637df
LC
598 (false-if-exception (delete-file template))
599 (close-port out)))))
861693f3 600
739ab68b
LC
601(define (cache-directory)
602 "Return the cache directory for Guix, by default ~/.cache/guix."
934c5d5b
LC
603 (string-append (or (getenv "XDG_CACHE_HOME")
604 (and=> (or (getenv "HOME")
605 (passwd:dir (getpwuid (getuid))))
606 (cut string-append <> "/.cache")))
607 "/guix"))
739ab68b 608
d50cb56d
LC
609(define (readlink* file)
610 "Call 'readlink' until the result is not a symlink."
611 (define %max-symlink-depth 50)
612
613 (let loop ((file file)
614 (depth 0))
615 (define (absolute target)
616 (if (absolute-file-name? target)
617 target
618 (string-append (dirname file) "/" target)))
619
620 (if (>= depth %max-symlink-depth)
621 file
622 (call-with-values
623 (lambda ()
624 (catch 'system-error
625 (lambda ()
626 (values #t (readlink file)))
627 (lambda args
628 (let ((errno (system-error-errno args)))
629 (if (or (= errno EINVAL))
630 (values #f file)
631 (apply throw args))))))
632 (lambda (success? target)
633 (if success?
634 (loop (absolute target) (+ depth 1))
635 file))))))
c8be6f0d
FB
636
637(define (canonical-newline-port port)
638 "Return an input port that wraps PORT such that all newlines consist
639 of a single carriage return."
640 (define (get-position)
641 (if (port-has-port-position? port) (port-position port) #f))
642 (define (set-position! position)
643 (if (port-has-set-port-position!? port)
644 (set-port-position! position port)
645 #f))
646 (define (close) (close-port port))
647 (define (read! bv start n)
648 (let loop ((count 0)
649 (byte (get-u8 port)))
650 (cond ((eof-object? byte) count)
651 ((= count (- n 1))
652 (bytevector-u8-set! bv (+ start count) byte)
653 n)
654 ;; XXX: consume all LFs even if not followed by CR.
655 ((eqv? byte (char->integer #\return)) (loop count (get-u8 port)))
656 (else
657 (bytevector-u8-set! bv (+ start count) byte)
658 (loop (+ count 1) (get-u8 port))))))
659 (make-custom-binary-input-port "canonical-newline-port"
660 read!
661 get-position
662 set-position!
663 close))
ff352cfb
LC
664\f
665;;;
666;;; Source location.
667;;;
668
cbbbb7be
LC
669(define (absolute-dirname file)
670 "Return the absolute name of the directory containing FILE, or #f upon
671failure."
672 (match (search-path %load-path file)
673 (#f #f)
674 ((? string? file)
675 ;; If there are relative names in %LOAD-PATH, FILE can be relative and
676 ;; needs to be canonicalized.
677 (if (string-prefix? "/" file)
678 (dirname file)
679 (canonicalize-path (dirname file))))))
680
5dbae738
LC
681(define-syntax current-source-directory
682 (lambda (s)
d4dd37fc
LC
683 "Return the absolute name of the current directory, or #f if it could not
684be determined."
5dbae738
LC
685 (syntax-case s ()
686 ((_)
687 (match (assq 'filename (syntax-source s))
688 (('filename . (? string? file-name))
d4dd37fc 689 ;; If %FILE-PORT-NAME-CANONICALIZATION is 'relative, then FILE-NAME
cbbbb7be
LC
690 ;; can be relative. In that case, we try to find out at run time
691 ;; the absolute file name by looking at %LOAD-PATH; doing this at
692 ;; run time rather than expansion time is necessary to allow files
693 ;; to be moved on the file system.
a68d0f6f
LC
694 (cond ((not file-name)
695 #f) ;raising an error would upset Geiser users
696 ((string-prefix? "/" file-name)
697 (dirname file-name))
698 (else
699 #`(absolute-dirname #,file-name))))
5dbae738
LC
700 (_
701 #f))))))
07c8a98c 702
ff352cfb
LC
703;; A source location.
704(define-record-type <location>
705 (make-location file line column)
706 location?
707 (file location-file) ; file name
708 (line location-line) ; 1-indexed line
709 (column location-column)) ; 0-indexed column
710
711(define location
55b2d921
LC
712 (mlambda (file line column)
713 "Return the <location> object for the given FILE, LINE, and COLUMN."
714 (and line column file
715 (make-location file line column))))
ff352cfb
LC
716
717(define (source-properties->location loc)
718 "Return a location object based on the info in LOC, an alist as returned
719by Guile's `source-properties', `frame-source', `current-source-location',
720etc."
721 (let ((file (assq-ref loc 'filename))
722 (line (assq-ref loc 'line))
723 (col (assq-ref loc 'column)))
5fe21fbe
LC
724 ;; In accordance with the GCS, start line and column numbers at 1. Note
725 ;; that unlike LINE and `port-column', COL is actually 1-indexed here...
726 (location file (and line (+ line 1)) col)))
f7df1e3e
SB
727
728(define (location->source-properties loc)
729 "Return the source property association list based on the info in LOC,
730a location object."
731 `((line . ,(and=> (location-line loc) 1-))
732 (column . ,(location-column loc))
733 (filename . ,(location-file loc))))