diff options
| -rw-r--r-- | guix/scripts/gc.scm | 2 | ||||
| -rw-r--r-- | guix/store.scm | 10 | ||||
| -rw-r--r-- | tests/guix-gc.sh | 20 |
3 files changed, 31 insertions, 1 deletions
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 4bae65a1ecc..a250cdc1975 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm | |||
| @@ -168,7 +168,7 @@ Invoke the garbage collector.\n")) | |||
| 168 | (collect-garbage store min-freed) | 168 | (collect-garbage store min-freed) |
| 169 | (collect-garbage store)))) | 169 | (collect-garbage store)))) |
| 170 | ((delete) | 170 | ((delete) |
| 171 | (delete-paths store paths)) | 171 | (delete-paths store (map direct-store-path paths))) |
| 172 | ((list-references) | 172 | ((list-references) |
| 173 | (list-relatives references)) | 173 | (list-relatives references)) |
| 174 | ((list-requisites) | 174 | ((list-requisites) |
diff --git a/guix/store.scm b/guix/store.scm index fc2f8d92ca8..8905a5a5580 100644 --- a/guix/store.scm +++ b/guix/store.scm | |||
| @@ -121,6 +121,7 @@ | |||
| 121 | derivation-path? | 121 | derivation-path? |
| 122 | store-path-package-name | 122 | store-path-package-name |
| 123 | store-path-hash-part | 123 | store-path-hash-part |
| 124 | direct-store-path | ||
| 124 | log-file)) | 125 | log-file)) |
| 125 | 126 | ||
| 126 | (define %protocol-version #x10c) | 127 | (define %protocol-version #x10c) |
| @@ -1012,6 +1013,15 @@ valid inputs." | |||
| 1012 | (let ((len (+ 1 (string-length (%store-prefix))))) | 1013 | (let ((len (+ 1 (string-length (%store-prefix))))) |
| 1013 | (not (string-index (substring path len) #\/))))) | 1014 | (not (string-index (substring path len) #\/))))) |
| 1014 | 1015 | ||
| 1016 | (define (direct-store-path path) | ||
| 1017 | "Return the direct store path part of PATH, stripping components after | ||
| 1018 | '/gnu/store/xxxx-foo'." | ||
| 1019 | (let ((prefix-length (+ (string-length (%store-prefix)) 35))) | ||
| 1020 | (if (> (string-length path) prefix-length) | ||
| 1021 | (let ((slash (string-index path #\/ prefix-length))) | ||
| 1022 | (if slash (string-take path slash) path)) | ||
| 1023 | path))) | ||
| 1024 | |||
| 1015 | (define (derivation-path? path) | 1025 | (define (derivation-path? path) |
| 1016 | "Return #t if PATH is a derivation path." | 1026 | "Return #t if PATH is a derivation path." |
| 1017 | (and (store-path? path) (string-suffix? ".drv" path))) | 1027 | (and (store-path? path) (string-suffix? ".drv" path))) |
diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh index eac9d82e898..c1eb66cef53 100644 --- a/tests/guix-gc.sh +++ b/tests/guix-gc.sh | |||
| @@ -64,3 +64,23 @@ guix gc -C 1KiB | |||
| 64 | # Check trivial error cases. | 64 | # Check trivial error cases. |
| 65 | if guix gc --delete /dev/null; | 65 | if guix gc --delete /dev/null; |
| 66 | then false; else true; fi | 66 | then false; else true; fi |
| 67 | |||
| 68 | # Bug #19757 | ||
| 69 | out="`guix build guile-bootstrap`" | ||
| 70 | test -d "$out" | ||
| 71 | |||
| 72 | guix gc --delete "$out" | ||
| 73 | |||
| 74 | ! test -d "$out" | ||
| 75 | |||
| 76 | out="`guix build guile-bootstrap`" | ||
| 77 | test -d "$out" | ||
| 78 | |||
| 79 | guix gc --delete "$out/" | ||
| 80 | |||
| 81 | ! test -d "$out" | ||
| 82 | |||
| 83 | out="`guix build guile-bootstrap`" | ||
| 84 | test -d "$out" | ||
| 85 | |||
| 86 | guix gc --delete "$out/bin/guile" | ||
