From 4ad6d1b85a94e879ef5da95746cc6896b2906f6c Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Thu, 29 Apr 2021 13:14:18 -0700 Subject: add connattrs Signed-off-by: Sean Whitton --- src/connection.lisp | 40 +++++++++++++++++++++++++++++++++++++++- 1 file changed, 39 insertions(+), 1 deletion(-) (limited to 'src/connection.lisp') diff --git a/src/connection.lisp b/src/connection.lisp index 9f71bc7..d69f157 100644 --- a/src/connection.lisp +++ b/src/connection.lisp @@ -83,7 +83,10 @@ For an example of usage, see the :SUDO connection type.")) (remote-user :initform nil :documentation - "The name of the remote user."))) + "The name of the remote user.") + (connattrs + :initform nil + :documentation "This connection's connection attributes."))) (defclass lisp-connection (connection) ()) @@ -445,3 +448,38 @@ established. Occasionally useful for testing purposes at the REPL." (let ((*connection* (establish-connection :sudo nil :user "root" :password nil))) ,@forms))) + + +;;;; Connection attributes + +(defgeneric propagate-connattr (type connattr connection) + (:documentation + "Possibly propagate CONNATTR, a connattr identified by TYPE, through to the +newly-established CONNECTION. Implementations should specialise on TYPE and +CONNECTION, not modify any of their arguments, and either return the new +connattr, or nil if nothing should be propagated.") + (:method (type connattr connection) + "Default implementation: don't propagate." + nil)) + +(defmethod initialize-instance :after ((connection connection) &key) + "Propagate connattrs which should be propagated." + (with-slots (parent) connection + (when (and parent (slot-boundp parent 'connattrs)) + (doplist (k v (slot-value parent 'connattrs)) + (when-let ((new (propagate-connattr k v connection))) + (setf (getf (slot-value connection 'connattrs) k) new)))))) + +(defun get-connattr (k) + "Get the connattr identified by K for the current connection." + (getf (slot-value *connection* 'connattrs) k)) + +(defmacro with-connattrs ((&rest connattrs) &body forms) + "Execute FORMS with connattrs replaced as specified by CONNATTRS, a plist." + (with-gensyms (old) + `(with-slots (connattrs) *connection* + (let ((,old connattrs)) + (setf connattrs (copy-list connattrs)) + (doplist (k v (list ,@connattrs)) (setf (getf connattrs k) v)) + (unwind-protect (progn ,@forms) + (setf connattrs ,old)))))) -- cgit v1.2.3