From f694b31597f3e57ff2a4a6631aff6f76b958a1e1 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Tue, 20 Apr 2021 22:12:25 -0700 Subject: add COPY-VOLUME-AND-CONTENTS Signed-off-by: Sean Whitton --- src/property/disk.lisp | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) (limited to 'src/property/disk.lisp') diff --git a/src/property/disk.lisp b/src/property/disk.lisp index 8124b76..93f4466 100644 --- a/src/property/disk.lisp +++ b/src/property/disk.lisp @@ -60,6 +60,31 @@ plus any metadata (e.g. partition tables), this value will be ignored.")) (define-print-object-for-structlike volume) +(defgeneric copy-volume-and-contents + (volume &rest initialisations &key &allow-other-keys) + (:documentation + "Make a fresh copy of VOLUME, shallowly, except for the VOLUME-CONTENTS of +volume, which is recursively copied. Keyword arguments may be used to +subsequently replace the copied values of some slots.")) + +(defmethod copy-volume-and-contents + ((volume volume) &rest initialisations &key &allow-other-keys) + (let* ((class (class-of volume)) + (copy (allocate-instance class)) + (contents-bound-p (slot-boundp volume 'volume-contents)) + (contents (and contents-bound-p (volume-contents volume)))) + (dolist (slot-name (delete 'volume-contents + (mapcar #'closer-mop:slot-definition-name + (closer-mop:class-slots class)))) + (when (slot-boundp volume slot-name) + (setf (slot-value copy slot-name) (slot-value volume slot-name)))) + (when contents-bound-p + (setf (volume-contents copy) + (if (listp contents) + (mapcar #'copy-volume-and-contents contents) + (copy-volume-and-contents contents)))) + (apply #'reinitialize-instance copy initialisations))) + (defmethod subvolumes-of-type ((type symbol) (volume volume)) "Recursively examine VOLUME and its VOLUME-CONTENTS and return a list of all volumes encountered whose type is a subtype of TYPE." -- cgit v1.2.3