From e49951eb3e1e1a8e7bad6d7471483e70b0865352 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 14 Feb 2013 04:15:25 -0500 Subject: Replace individual scripts with master 'guix' script. * scripts/guix.in: New script. * Makefile.am (bin_SCRIPTS): Add 'scripts/guix'. Remove 'guix-build', 'guix-download', 'guix-import', 'guix-package', and 'guix-gc'. (MODULES): Add 'guix/scripts/build.scm', 'guix/scripts/download.scm', 'guix/scripts/import.scm', 'guix/scripts/package.scm', and 'guix/scripts/gc.scm'. * configure.ac (AC_CONFIG_FILES): Add 'scripts/guix'. Remove 'guix-build', 'guix-download', 'guix-import', 'guix-package', and 'guix-gc'. * guix-build.in, guix-download.in, guix-gc.in, guix-import.in, guix-package.in: Remove shell script boilerplate. Move to guix-COMMAND.in to guix/scripts/COMMAND.scm. Rename module from (guix-COMMAND) to (guix scripts COMMAND). Change "guix-COMMAND" to "guix COMMAND" in usage help string. * pre-inst-env.in: Add "@abs_top_builddir@/scripts" to the front of $PATH. Export $GUIX_UNINSTALLED. * tests/guix-build.sh, tests/guix-daemon.sh, tests/guix-download.sh, tests/guix-gc.sh, tests/guix-package.sh: Use "guix COMMAND" instead of "guix-COMMAND". * doc/guix.texi: Replace all occurrences of "guix-COMMAND" with "guix COMMAND". * po/POTFILES.in: Update. --- guix/scripts/gc.scm | 165 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 165 insertions(+) create mode 100644 guix/scripts/gc.scm (limited to 'guix/scripts/gc.scm') diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm new file mode 100644 index 0000000000..8e2587186e --- /dev/null +++ b/guix/scripts/gc.scm @@ -0,0 +1,165 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix scripts gc) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-gc)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((action . collect-garbage))) + +(define (show-help) + (display (_ "Usage: guix gc [OPTION]... PATHS... +Invoke the garbage collector.\n")) + (display (_ " + -C, --collect-garbage[=MIN] + collect at least MIN bytes of garbage")) + (display (_ " + -d, --delete attempt to delete PATHS")) + (display (_ " + --list-dead list dead paths")) + (display (_ " + --list-live list live paths")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define (size->number str) + "Convert STR, a storage measurement representation such as \"1024\" or +\"1MiB\", to a number of bytes. Raise an error if STR could not be +interpreted." + (define unit-pos + (string-rindex str char-set:digit)) + + (define unit + (and unit-pos (substring str (+ 1 unit-pos)))) + + (let* ((numstr (if unit-pos + (substring str 0 (+ 1 unit-pos)) + str)) + (num (string->number numstr))) + (if num + (* num + (match unit + ("KiB" (expt 2 10)) + ("MiB" (expt 2 20)) + ("GiB" (expt 2 30)) + ("TiB" (expt 2 40)) + ("KB" (expt 10 3)) + ("MB" (expt 10 6)) + ("GB" (expt 10 9)) + ("TB" (expt 10 12)) + ("" 1) + (_ + (format (current-error-port) (_ "error: unknown unit: ~a~%") + unit) + (exit 1)))) + (begin + (format (current-error-port) + (_ "error: invalid number: ~a") numstr) + (exit 1))))) + +(define %options + ;; Specification of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix-gc"))) + + (option '(#\C "collect-garbage") #f #t + (lambda (opt name arg result) + (let ((result (alist-cons 'action 'collect-garbage + (alist-delete 'action result)))) + (match arg + ((? string?) + (let ((amount (size->number arg))) + (if arg + (alist-cons 'min-freed amount result) + (begin + (format (current-error-port) + (_ "error: invalid amount of storage: ~a~%") + arg) + (exit 1))))) + (#f result))))) + (option '(#\d "delete") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'delete + (alist-delete 'action result)))) + (option '("list-dead") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'list-dead + (alist-delete 'action result)))) + (option '("list-live") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'list-live + (alist-delete 'action result)))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-gc . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (with-error-handling + (let ((opts (parse-options)) + (store (open-connection))) + (case (assoc-ref opts 'action) + ((collect-garbage) + (let ((min-freed (assoc-ref opts 'min-freed))) + (if min-freed + (collect-garbage store min-freed) + (collect-garbage store)))) + ((delete) + (let ((paths (filter-map (match-lambda + (('argument . arg) arg) + (_ #f)) + opts))) + (delete-paths store paths))) + ((list-dead) + (for-each (cut simple-format #t "~a~%" <>) + (dead-paths store))) + ((list-live) + (for-each (cut simple-format #t "~a~%" <>) + (live-paths store))))))) -- cgit v1.2.3