From 65f224dc8d9568232baa07f28474ba5c90f07428 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 31 May 2017 15:23:51 +0200
Subject: [PATCH] syscalls: Provide 'free-disk-space'.
* guix/build/syscalls.scm (free-disk-space): New procedure.
* guix/scripts/gc.scm (guix-gc)[ensure-free-space]: Use it instead of
'statfs'.
---
guix/build/syscalls.scm | 7 +++++++
guix/scripts/gc.scm | 8 +++-----
2 files changed, 10 insertions(+), 5 deletions(-)
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 52439afd440..2def2a108f9 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -62,6 +62,7 @@ (define-module (guix build syscalls)
file-system-fragment-size
file-system-mount-flags
statfs
+ free-disk-space
processes
mkdtemp!
@@ -697,6 +698,12 @@ (define statfs
(list file (strerror err))
(list err)))))))
+(define (free-disk-space file)
+ "Return the free disk space, in bytes, on the file system that hosts FILE."
+ (let ((fs (statfs file)))
+ (* (file-system-block-size fs)
+ (file-system-blocks-available fs))))
+
;;;
;;; Containers.
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index 221467a1081..0a9719d2598 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -20,7 +20,7 @@ (define-module (guix scripts gc)
#:use-module (guix ui)
#:use-module (guix scripts)
#:use-module (guix store)
- #:autoload (guix build syscalls) (statfs)
+ #:autoload (guix build syscalls) (free-disk-space)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
@@ -184,9 +184,7 @@ (define (store-directory file)
(define (ensure-free-space store space)
;; Attempt to have at least SPACE bytes available in STORE.
- (let* ((fs (statfs (%store-prefix)))
- (free (* (file-system-block-size fs)
- (file-system-blocks-available fs))))
+ (let ((free (free-disk-space (%store-prefix))))
(if (> free space)
(info (G_ "already ~h bytes available on ~a, nothing to do~%")
free (%store-prefix))
--
GitLab