diff options
| -rw-r--r-- | src/connection.lisp | 5 | ||||
| -rw-r--r-- | src/package.lisp | 1 | ||||
| -rw-r--r-- | src/property/mount.lisp | 18 |
3 files changed, 18 insertions, 6 deletions
diff --git a/src/connection.lisp b/src/connection.lisp index 9159a02..782160a 100644 --- a/src/connection.lisp +++ b/src/connection.lisp @@ -481,6 +481,11 @@ subclass to the :HOSTATTRS subroutine of properties calling this." "Recursively delete each of PATHS." (mrun "rm" "-rf" paths)) +(defun empty-remote-directory (directory) + "Recursively delete the contents of DIRECTORY, but not DIRECTORY itself." + (let ((d (escape-sh-token (drop-trailing-slash (unix-namestring directory))))) + (mrun (format nil "rm -rf -- ~A/* ~A/.[!.]* ~A/..?*" d d d)))) + (defun remote-exists-p (&rest paths) "Does each of PATHS exists? PATH may be any kind of file, including directories." diff --git a/src/package.lisp b/src/package.lisp index d5aed60..2cbff57 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -153,6 +153,7 @@ #:remote-consfigurator-cache-pathname #:mountpointp #:delete-remote-trees + #:empty-remote-directory #:readfile #:writefile #:get-connattr diff --git a/src/property/mount.lisp b/src/property/mount.lisp index c00ed23..f4a06ed 100644 --- a/src/property/mount.lisp +++ b/src/property/mount.lisp @@ -76,12 +76,18 @@ this property will empty /dev, breaking all kinds of things." do (loop while (subpathp (car sorted) next) do (pop sorted)) (mrun "umount" "--recursive" next))))) -(defproplist unmounted-below-and-removed :posix (dir) - "Unmount anything mounted at or below DIR and recursively delete dir." - (:desc #?"${dir} unmounted and removed") - (:check (not (remote-exists-p dir))) - (unmounted-below dir) - (cmd:single "rm" "-rf" dir)) +(defprop unmounted-below-and-removed :posix (dir) + "Unmount anything mounted below DIR, recursively delete the contents of DIR, +and unless DIR is itself a mount point, also remove DIR." + (:desc #?"${dir} unmounted below and emptied/removed") + (:hostattrs (os:required 'os:linux)) + (:check (or (not (remote-exists-p dir)) + (and (mountpointp dir) + (null (runlines "find" dir "-not" "-path" dir))))) + (:apply (ignoring-hostattrs (unmounted-below dir :and-at nil)) + (if (mountpointp dir) + (empty-remote-directory dir) + (delete-remote-trees dir)))) (defun all-mounts (&optional (below #P"/")) "Retrieve all mountpoints below BELOW, ordered lexicographically. |