94 lines
3.1 KiB
Scheme
94 lines
3.1 KiB
Scheme
|
;;; GNU Guix --- Functional package management for GNU
|
||
|
|
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
|
||
|
|
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
|
||
|
|
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
|
||
|
|
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
|
||
|
|
;;;
|
||
|
|
;;; This file is part of GNU Guix.
|
||
|
|
;;;
|
||
|
|
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||
|
|
;;; under the terms of the GNU General Public License as published by
|
||
|
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||
|
|
;;; your option) any later version.
|
||
|
|
;;;
|
||
|
|
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
|
|
;;; GNU General Public License for more details.
|
||
|
|
;;;
|
||
|
|
;;; You should have received a copy of the GNU General Public License
|
||
|
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||
|
|
|
||
|
|
(define-module (guix shell-utils)
|
||
|
|
#:use-module (ice-9 match)
|
||
|
|
#:use-module (rnrs bytevectors)
|
||
|
|
#:use-module (rnrs io ports)
|
||
|
|
#:export (dump-port
|
||
|
|
mkdir-p
|
||
|
|
with-directory-excursion))
|
||
|
|
|
||
|
|
;;;
|
||
|
|
;;; Directories.
|
||
|
|
;;;
|
||
|
|
|
||
|
|
(define (mkdir-p dir)
|
||
|
|
"Create directory DIR and all its ancestors."
|
||
|
|
(define absolute?
|
||
|
|
(string-prefix? "/" dir))
|
||
|
|
|
||
|
|
(define not-slash
|
||
|
|
(char-set-complement (char-set #\/)))
|
||
|
|
|
||
|
|
(let loop ((components (string-tokenize dir not-slash))
|
||
|
|
(root (if absolute?
|
||
|
|
""
|
||
|
|
".")))
|
||
|
|
(match components
|
||
|
|
((head tail ...)
|
||
|
|
(let ((path (string-append root "/" head)))
|
||
|
|
(catch 'system-error
|
||
|
|
(lambda ()
|
||
|
|
(mkdir path)
|
||
|
|
(loop tail path))
|
||
|
|
(lambda args
|
||
|
|
(if (= EEXIST (system-error-errno args))
|
||
|
|
(loop tail path)
|
||
|
|
(apply throw args))))))
|
||
|
|
(() #t))))
|
||
|
|
|
||
|
|
(define-syntax-rule (with-directory-excursion dir body ...)
|
||
|
|
"Run BODY with DIR as the process's current directory."
|
||
|
|
(let ((init (getcwd)))
|
||
|
|
(dynamic-wind
|
||
|
|
(lambda ()
|
||
|
|
(chdir dir))
|
||
|
|
(lambda ()
|
||
|
|
body ...)
|
||
|
|
(lambda ()
|
||
|
|
(chdir init)))))
|
||
|
|
|
||
|
|
(define* (dump-port in out
|
||
|
|
#:key (buffer-size 16384)
|
||
|
|
(progress (lambda (t k) (k))))
|
||
|
|
"Read as much data as possible from IN and write it to OUT, using chunks of
|
||
|
|
BUFFER-SIZE bytes. Call PROGRESS at the beginning and after each successful
|
||
|
|
transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes
|
||
|
|
transferred and the continuation of the transfer as a thunk."
|
||
|
|
(define buffer
|
||
|
|
(make-bytevector buffer-size))
|
||
|
|
|
||
|
|
(define (loop total bytes)
|
||
|
|
(or (eof-object? bytes)
|
||
|
|
(let ((total (+ total bytes)))
|
||
|
|
(put-bytevector out buffer 0 bytes)
|
||
|
|
(progress total
|
||
|
|
(lambda ()
|
||
|
|
(loop total
|
||
|
|
(get-bytevector-n! in buffer 0 buffer-size)))))))
|
||
|
|
|
||
|
|
;; Make sure PROGRESS is called when we start so that it can measure
|
||
|
|
;; throughput.
|
||
|
|
(progress 0
|
||
|
|
(lambda ()
|
||
|
|
(loop 0 (get-bytevector-n! in buffer 0 buffer-size)))))
|