diff options
| -rw-r--r-- | src/property.lisp | 29 | ||||
| -rw-r--r-- | src/property/os.lisp | 3 | ||||
| -rw-r--r-- | src/propspec.lisp | 5 | ||||
| -rw-r--r-- | src/util.lisp | 8 |
4 files changed, 24 insertions, 21 deletions
diff --git a/src/property.lisp b/src/property.lisp index 04d3780..ad47adb 100644 --- a/src/property.lisp +++ b/src/property.lisp @@ -346,10 +346,10 @@ other than constant values and propapps to property combinators." ;;;; hostattrs in property subroutines -(define-condition inapplicable-property (error) - ((text :initarg :text :reader inapplicable-property-text)) - (:report (lambda (condition stream) - (format stream "~A" (inapplicable-property-text condition))))) +(define-simple-error inapplicable-property + "Signal, in a :HOSTATTRS subroutine, that the host's hostattrs indicate that +this property cannot be applied to this host. E.g. the property will try to +install an apt package but the host is FreeBSD.") (defun get-hostattrs (k) "Retrieve the list of static informational attributes of type KEY. @@ -390,13 +390,9 @@ Called by property subroutines." ;;;; :APPLY subroutines -;; INAPPLICABLE-PROPERTY is for :HOSTATTRS subroutines, FAILED-CHANGE is for -;; problems with the connection and errors while actually attempting to apply - -(define-condition failed-change (error) - ((text :initarg :text :reader failed-change-text)) - (:report (lambda (condition stream) - (format stream "~A" (failed-change-text condition))))) +(define-simple-error failed-change + "Signal problems with the connection and errors while actually attempting to +apply or unapply properties.") (defun call-with-os (f &rest args) (apply (ensure-function f) (get-hostattrs-car :os) args)) @@ -405,18 +401,17 @@ Called by property subroutines." "Assert that the remote user has uid 0 (root)" (if-let (uid (slot-value *connection* 'remote-uid)) (unless (zerop uid) - (error 'failed-change :text "Property requires root to apply")) + (failed-change "Property requires root to apply")) (multiple-value-bind (out err exit) (run :may-fail "id" "-u") (unless (zerop exit) - (error 'failed-change - :text #?"Failed to run id(1) on remote system: ${err}")) + (failed-change #?"Failed to run id(1) on remote system: ${err}")) (let ((new-uid (parse-integer out))) (unless (zerop new-uid) - (error 'failed-change :text "Property requires root to apply")) + (failed-change "Property requires root to apply")) (setf (slot-value *connection* 'remote-uid) new-uid))))) (defun assert-connection-supports (type) (unless (or (eq type :posix) (lisp-connection-p)) - (error 'failed-change - "Cannot apply :LISP properties using a POSIX-type connection"))) + (failed-change + "Cannot apply :LISP properties using a POSIX-type connection"))) diff --git a/src/property/os.lisp b/src/property/os.lisp index 6a23e97..67d0ebd 100644 --- a/src/property/os.lisp +++ b/src/property/os.lisp @@ -97,8 +97,7 @@ Used in property :HOSTATTRS subroutines." (let ((os (class-of (get-hostattrs-car :os)))) (unless (and os (subtypep os type)) - (error 'inapplicable-property - :text #?"Property requires OS of type ${type}")))) + (inapplicable-property #?"Property requires OS of type ${type}")))) (defun supports-arch-p (os arch) "Can binaries of type ARCH run on OS?" diff --git a/src/propspec.lisp b/src/propspec.lisp index c51b7df..2c199e5 100644 --- a/src/propspec.lisp +++ b/src/propspec.lisp @@ -337,8 +337,9 @@ apply the elements of REQUIREMENTS in reverse order." (or (loop with host = (class-of (get-hostattrs-car :os)) for (type propapp) on cases by #'cddr when (subtypep host type) return propapp) - (error 'inapplicable-property - :text "Host's OS fell through OS:TYPECASE.")))) + (inapplicable-property + "Host's OS ~S fell through OS:TYPECASE." + (class-of (get-hostattrs-car :os)))))) (retprop :type (collapse-types (loop for propapp in (cdr cases) by #'cddr collect (propapptype propapp))) :desc (lambda (&rest args) diff --git a/src/util.lisp b/src/util.lisp index f9098b1..903c330 100644 --- a/src/util.lisp +++ b/src/util.lisp @@ -71,6 +71,14 @@ supported." unless (char= #\& (char (symbol-name arg*) 0)) collect arg*)) +(defmacro define-simple-error (name &optional docstring) + `(progn + (define-condition ,name (simple-error) () + ,@(and docstring `((:documentation ,docstring)))) + (defun ,name (message &rest args) + ,@(and docstring `(,docstring)) + (error ',name :format-control message :format-arguments args)))) + ;;;; Version numbers |