From 4ce70f3f2caf05910d43cddd7ce2328ce078585b Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Mon, 13 Jun 2022 16:40:39 -0500 Subject: factor out PROG-CHANGES Signed-off-by: Sean Whitton --- src/combinator.lisp | 151 +++++++++++++++++++++++++--------------------------- src/package.lisp | 3 ++ src/util.lisp | 14 +++++ 3 files changed, 91 insertions(+), 77 deletions(-) (limited to 'src') diff --git a/src/combinator.lisp b/src/combinator.lisp index da0594a..1613bf3 100644 --- a/src/combinator.lisp +++ b/src/combinator.lisp @@ -148,86 +148,83 @@ apply the elements of REQUIREMENTS in reverse order." &aux (buffer (make-array '(0) :element-type 'character :fill-pointer 0 :adjustable t)) - (return-value :no-change) ;; Remove any null propapps because we don't want to print anything for ;; those, and applying them will do nothing. (propapps (remove nil (if unapply (reverse propapps) propapps)))) - (dolist (propapp propapps return-value) - (let* ((combinator (get (car propapp) 'combinator)) - (announce - (and (not silent) - (or (> *consfigurator-debug-level* 2) - (not (get combinator 'inline-combinator))) - ;; We don't announce properties whose names begin with '%' - ;; and which have no description; these are typically - ;; DEFPROPs which exist only for use within a - ;; DEFPROPLIST/DEFPROPSPEC defining an exported property. - (not (and (< *consfigurator-debug-level* 3) - (char= #\% (char (symbol-name (car propapp)) 0)) - (not (get (car propapp) 'desc))))))) - (flet ((accumulate (result) - (unless (eql result :no-change) (setq return-value result))) - (post-apply (status) - (when propapp - (when (and (plusp (length buffer)) - (or silent - (> *consfigurator-debug-level* 1) - (not (string= status "ok")))) - (fresh-line) - (princ buffer)) - (when announce - (informat t "~&~@[~A :: ~]~@[~A ... ~]~A~%" - (get-hostname) (propapp-desc propapp) status)) - ;; Ensure POST-APPLY called exactly once for each propapp. - (setq propapp nil))) - - (test (c) (subtypep (type-of c) 'aborted-change)) - (ntest (c) (not (subtypep (type-of c) 'aborted-change))) - - (pareport (s) - (format s "Skip (~{~S~^ ~})" - (cons (car propapp) (propapp-args propapp)))) - (seqreport (s) - (format s "Skip remainder of sequence containing (~{~S~^ ~})" - (cons (car propapp) (propapp-args propapp))))) - (unwind-protect - ;; Establish restarts to be invoked by WITH-SKIP-FAILED-CHANGES - ;; or possibly interactively by the user. There are two of each - ;; because we want to handle ABORTED-CHANGE specially. - (restart-case - (alet (if announce - (with-output-to-string (*standard-output* buffer) - (with-indented-inform - (if unapply - (unapply-propapp propapp) - (apply-propapp propapp)))) - (if unapply - (unapply-propapp propapp) - (apply-propapp propapp))) - (accumulate it) - (post-apply (if (eql it :no-change) "ok" "done"))) - ;; Standard restarts for skipping over sequence entries. - (skip-property () :test ntest :report pareport - (signal 'skipped-properties) (post-apply "failed") - (accumulate nil)) - (skip-property () :test test :report pareport - (signal 'skipped-properties) (post-apply "failed") - (accumulate :no-change)) - ;; Special restarts for the whole sequence which return from - ;; the enclosing DOLIST based on the kind of error. If - ;; ABORTED-CHANGE, we assume that applying the current propapp - ;; made no change, so we return a value indicating whether - ;; properties earlier in PROPAPPS made a change. Otherwise, we - ;; assume that some change was made. - (skip-sequence () :test ntest :report seqreport - (signal 'skipped-properties) (post-apply "failed") - (return)) - (skip-sequence () :test test :report seqreport - (signal 'skipped-properties) (post-apply "failed") - (return return-value))) - ;; Ensure we print out the buffer contents if due to a non-local - ;; exit neither of the other calls to POST-APPLY have been made. - (post-apply "failed")) + (prog-changes + (dolist (propapp propapps) + (let* ((combinator (get (car propapp) 'combinator)) + (announce + (and (not silent) + (or (> *consfigurator-debug-level* 2) + (not (get combinator 'inline-combinator))) + ;; We don't announce properties whose names begin with '%' + ;; and which have no description; these are typically + ;; DEFPROPs which exist only for use within a + ;; DEFPROPLIST/DEFPROPSPEC defining an exported property. + (not (and (< *consfigurator-debug-level* 3) + (char= #\% (char (symbol-name (car propapp)) 0)) + (not (get (car propapp) 'desc))))))) + (flet ((post-apply (status) + (when propapp + (when (and (plusp (length buffer)) + (or silent + (> *consfigurator-debug-level* 1) + (not (string= status "ok")))) + (fresh-line) + (princ buffer)) + (when announce + (informat t "~&~@[~A :: ~]~@[~A ... ~]~A~%" + (get-hostname) (propapp-desc propapp) status)) + ;; Ensure POST-APPLY called exactly once for each propapp. + (setq propapp nil))) + + (test (c) (subtypep (type-of c) 'aborted-change)) + (ntest (c) (not (subtypep (type-of c) 'aborted-change))) + + (pareport (s) + (format s "Skip (~{~S~^ ~})" + (cons (car propapp) (propapp-args propapp)))) + (seqreport (s) + (format s "Skip remainder of sequence containing (~{~S~^ ~})" + (cons (car propapp) (propapp-args propapp))))) + (unwind-protect + ;; Establish restarts to be invoked by WITH-SKIP-FAILED-CHANGES + ;; or possibly interactively by the user. There are two of + ;; each because we want to handle ABORTED-CHANGE specially. + (restart-case + (alet (add-change + (if announce + (with-output-to-string (*standard-output* buffer) + (with-indented-inform + (if unapply + (unapply-propapp propapp) + (apply-propapp propapp)))) + (if unapply + (unapply-propapp propapp) + (apply-propapp propapp)))) + (post-apply (if (eql it :no-change) "ok" "done"))) + ;; Standard restarts for skipping over sequence entries. + (skip-property () :test ntest :report pareport + (signal 'skipped-properties) (post-apply "failed") + (add-change)) + (skip-property () :test test :report pareport + (signal 'skipped-properties) (post-apply "failed")) + ;; Special restarts for the whole sequence which return from + ;; the enclosing DOLIST based on the kind of error. If + ;; ABORTED-CHANGE, we assume that applying the current + ;; propapp made no change, so we return a value indicating + ;; whether properties earlier in PROPAPPS made a change. + ;; Otherwise, we assume that some change was made. + (skip-sequence () :test ntest :report seqreport + (signal 'skipped-properties) (post-apply "failed") + (return-from prog-changes)) + (skip-sequence () :test test :report seqreport + (signal 'skipped-properties) (post-apply "failed") + (return-changes))) + ;; Ensure we print out the buffer contents if due to a non-local + ;; exit neither of the other calls to POST-APPLY have been made. + (post-apply "failed"))) (setf (fill-pointer buffer) 0))))) (defmacro unapply (form) diff --git a/src/package.lisp b/src/package.lisp index 097af65..df05b19 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -128,6 +128,9 @@ #:parse-cidr #:random-alphanumeric #:valid-hostname-p + #:prog-changes + #:add-change + #:return-changes #:*consfigurator-debug-level* #:with-indented-inform diff --git a/src/util.lisp b/src/util.lisp index e20b113..61be8b7 100644 --- a/src/util.lisp +++ b/src/util.lisp @@ -415,6 +415,20 @@ expansion as a starting point for your own DEFPACKAGE form for your consfig." (re:scan "^[a-zA-Z0-9][a-zA-Z0-9-]*$" part))) parts)))) +(defmacro prog-changes (&body body) + (with-gensyms (result) + `(let ((,result :no-change)) + (block prog-changes + (flet ((add-change (&optional result) + (case result + (:no-change result) + (t (setq ,result result)))) + (return-changes () + (return-from prog-changes ,result))) + (declare (ignorable #'return-changes)) + ,@body + ,result))))) + ;;;; Progress & debug printing -- cgit v1.2.3