diff --git a/clog-connection.lisp b/clog-connection.lisp index 864daab..abdcd23 100644 --- a/clog-connection.lisp +++ b/clog-connection.lisp @@ -26,9 +26,10 @@ script." (*verbose-output* variable) - (initialize function) - (shutdown-clog function) - (set-on-connect function) + (initialize function) + (shutdown-clog function) + (set-on-connect function) + (get-connection-data function) "CLOG system utilities" @@ -60,8 +61,9 @@ script." (defvar *new-id* 0 "Last issued connection or script IDs") -(defvar *connections* (make-hash-table) "Connections to IDs") -(defvar *connection-ids* (make-hash-table) "IDs to connections") +(defvar *connections* (make-hash-table) "Connections to IDs") +(defvar *connection-ids* (make-hash-table) "IDs to connections") +(defvar *connection-data* (make-hash-table) "Connection based data") (defvar *connection-lock* (bordeaux-threads:make-lock) "Protect the connection hash tables") @@ -91,6 +93,16 @@ script." "Return the connection associated with CONNECITION-ID. (Private)" (gethash connection-id *connection-ids*)) +;;;;;;;;;;;;;;;;;;;;;;;;; +;; get-connection-data ;; +;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun get-connection-data (connection-id) + "Return the connecton data associated with the CONNECTION-ID a +hash test: #'equal." + (gethash connection-id *connection-data*)) + + ;;;;;;;;;;;;;;;; ;; prep-query ;; ;;;;;;;;;;;;;;;; @@ -131,7 +143,9 @@ the default answer. (Private)" (setf id (generate-id)) (bordeaux-threads:with-lock-held (*connection-lock*) (setf (gethash connection *connections*) id) - (setf (gethash id *connection-ids*) connection)) + (setf (gethash id *connection-ids*) connection) + (setf (gethash id *connection-data*) (make-hash-table :test #'equal)) + (setf (gethash "connection-id" (get-connection-data id)) id)) (when *verbose-output* (format t "New connection id - ~A - ~A~%" id connection)) (websocket-driver:send connection @@ -147,16 +161,22 @@ the default answer. (Private)" (defun handle-message (connection message) (let ((id (gethash connection *connections*)) (ml (ppcre:split ":" message :limit 2))) - (cond ((equal (car ml) "0") + (cond ((equal (first ml) "0") (when *verbose-output* - (format t "~A Ping ~A~%" id (car ml)))) + (format t "~A Ping~%" id))) + ((equal (first ml) "E") + (let ((em (ppcre:split "-" (second ml) :limit 2))) + (when *verbose-output* + (format t "Channel ~A Hook ~A Data ~A~%" + id (first em) (second em))) + (funcall (gethash (first em) (get-connection-data id))))) (t (when *verbose-output* - (format t "~A ~A = ~A~%" id (car ml) (cadr ml))) + (format t "~A ~A = ~A~%" id (first ml) (second ml))) (bordeaux-threads:with-lock-held (*queries-lock*) - (setf (gethash (parse-integer (car ml)) *queries*) (cadr ml))) + (setf (gethash (parse-integer (first ml)) *queries*) (second ml))) (bordeaux-threads:signal-semaphore - (gethash (parse-integer (car ml)) *queries-sems*)))))) + (gethash (parse-integer (first ml)) *queries-sems*)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; handle-close-connection ;; @@ -168,6 +188,7 @@ the default answer. (Private)" (when *verbose-output* (format t "Connection id ~A has closed. ~A~%" id connection)) (bordeaux-threads:with-lock-held (*connection-lock*) + (remhash id *connection-data*) ;; reconnects would lose data? (remhash id *connection-ids*) (remhash connection *connections*))))) diff --git a/clog.lisp b/clog.lisp index 64d94cd..baccd8e 100644 --- a/clog.lisp +++ b/clog.lisp @@ -49,27 +49,31 @@ application." (clog-obj class) "CLOG-Obj - General Properties" - (property generic-function) - (style generic-function) - (attribute generic-function) + (property generic-function) + (style generic-function) + (attribute generic-function) - (height generic-function) - (width generic-function) + (height generic-function) + (width generic-function) "CLOG-Obj - General Methods" (focus generic-function) (blur generic-function) - "CLOG-Obj - Low Level" - (create-child generic-function) - (attach-as-child generic-function) - (validp generic-function) - "CLOG-Obj - Placement" (place-after generic-function) (place-before generic-function) (place-inside-top-of generic-function) - (place-inside-bottom-of generic-function)) + (place-inside-bottom-of generic-function) + + "CLOG-Obj - Low Level" + (create-child generic-function) + (attach-as-child generic-function) + (connection-data generic-function) + (validp generic-function) + + "CLOG-Obj - Event Handling" + (set-on-click generic-function)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -82,7 +86,10 @@ application." :initarg :connection-id) (html-id :reader html-id - :initarg :html-id)) + :initarg :html-id) + (event-handlers + :accessor event-handlers + :initform (make-hash-table :test #'equal))) (:documentation "CLOG objects (clog-obj) encapsulate the connection between lisp and the HTML DOM element.")) @@ -92,6 +99,9 @@ lisp and the HTML DOM element.")) (defgeneric html-id (clog-obj) (:documentation "Reader for html-id slot. (Private)")) +(defgeneric event-handlers (clog-obj) + (:documentation "Reader/writer for even-handler hash. (Private)")) + ;;;;;;;;;;;;;;;;;;; ;; make-clog-obj ;; ;;;;;;;;;;;;;;;;;;; @@ -153,80 +163,85 @@ result. (Private)")) ;;;;;;;;;;;;;; (defgeneric property (clog-obj property-name) - (:documentation "get/set html property. (eg. draggable)")) + (:documentation "Get/Setf html property. (eg. draggable)")) (defmethod property ((obj clog-obj) property-name) (jquery-query obj (format nil "prop('~A')" property-name))) -(defgeneric (setf property) (value obj property-name) - (:documentation "Setf PROPERTY-NAME to VALUE for CLOG-OBJ")) +(defgeneric set-property (clog-obj property-name value) + (:documentation "Set html property.")) -(defmethod (setf property) (value (obj clog-obj) property-name) +(defmethod set-property ((obj clog-obj) property-name value) (jquery-execute obj (format nil "prop('~A','~A')" property-name value))) +(defsetf property set-property) ;;;;;;;;;;; ;; style ;; ;;;;;;;;;;; (defgeneric style (clog-obj style-name) - (:documentation "get/set html css style.")) + (:documentation "Get/Setf css style.")) -(defmethod style ((obj clog-obj) style-name ) +(defmethod style ((obj clog-obj) style-name) (jquery-query obj (format nil "css('~A')" style-name))) -(defgeneric (setf style) (value clog-obj style-name) - (:documentation "Setf STYLE-NAME to VALUE for CLOG-OBJ")) +(defgeneric set-style (clog-obj style-name value) + (:documentation "Set css style.")) -(defmethod (setf style) (value (obj clog-obj) style-name) +(defmethod set-style ((obj clog-obj) style-name value) (jquery-execute obj (format nil "css('~A','~A')" style-name value))) +(defsetf style set-style) ;;;;;;;;;;;;;;; ;; attribute ;; ;;;;;;;;;;;;;;; (defgeneric attribute (clog-obj attribute-name) - (:documentation "get/set html attribute. (eg. src on img tag)")) + (:documentation "Get/Setf html tag attribute. (eg. src on img tag)")) (defmethod attribute ((obj clog-obj) attribute-name) (jquery-query obj (format nil "attr('~A')" attribute-name))) -(defgeneric (setf attribute) (value clog-obj attribute-name) - (:documentation "Setf ATTRIBUTE-NAME to VALUE for CLOG-OBJ")) +(defgeneric set-attribute (clog-obj attribute-name value) + (:documentation "Set html tag attribute.")) -(defmethod (setf attribute) (value (obj clog-obj) attribute-name) +(defmethod set-attribute ((obj clog-obj) attribute-name value) (jquery-execute obj (format nil "attr('~A','~A')" attribute-name value))) +(defsetf attribute set-attribute) ;;;;;;;;;;;; ;; height ;; ;;;;;;;;;;;; (defgeneric height (clog-obj) - (:documentation "get/set html height in pixels.")) + (:documentation "Get/Setf html height in pixels.")) (defmethod height ((obj clog-obj)) (jquery-query obj "height()")) -(defgeneric (setf height) (value clog-obj) - (:documentation "Setf height VALUE for CLOG-OBJ")) +(defgeneric set-height (clog-obj value) + (:documentation "Set height VALUE for CLOG-OBJ")) -(defmethod (setf height) (value (obj clog-obj)) +(defmethod set-height ((obj clog-obj) value) (jquery-execute obj (format nil "height('~A')" value))) +(defsetf height set-height) ;;;;;;;;;;; ;; width ;; ;;;;;;;;;;; (defgeneric width (clog-obj) - (:documentation "get/set html width in pixels.")) + (:documentation "Get/Setf html width in pixels.")) (defmethod width ((obj clog-obj)) (jquery-query obj "width()")) -(defgeneric (setf width) (value clog-obj) - (:documentation "Setf width VALUE for CLOG-OBJ")) +(defgeneric set-width (clog-obj value) + (:documentation "Set width VALUE for CLOG-OBJ")) -(defmethod (setf width) (value (obj clog-obj)) +(defmethod set-width ((obj clog-obj) value) (jquery-execute obj (format nil "width('~A')" value))) +(defsetf width set-width) ;;;;;;;;;;; ;; focus ;; @@ -285,6 +300,17 @@ HTML-ID must be unique.")) (defmethod validp ((obj clog-obj)) (cc:validp (connection-id obj))) +;;;;;;;;;;;;;;;;;;;;; +;; connection-data ;; +;;;;;;;;;;;;;;;;;;;;; + +(defgeneric connection-data (clog-obj) + (:documentation "Get connection-data that is associated with +clog-obj that will persist regardless of thread.")) + +(defmethod connection-data ((obj clog-obj)) + (cc:get-connection-data (connection-id obj))) + ;;;;;;;;;;;;;;;;; ;; place-after ;; ;;;;;;;;;;;;;;;;; @@ -329,6 +355,31 @@ HTML-ID must be unique.")) (jquery-execute obj (format nil "append(~A)" (script-id next-obj))) next-obj) +;;;;;;;;;;;;;;;;;; +;; set-on-click ;; +;;;;;;;;;;;;;;;;;; + +(defmethod bind-event-script ((obj clog-obj) event call-back) + (jquery-execute + obj (format nil "on('~A',function (e, data){~A})" event call-back))) + +(defmethod set-event ((obj clog-obj) event handler) + ;; meeds mutex + (let ((hook (format nil "~A:~A" (html-id obj) event))) + (cond (handler + (bind-event-script obj event + (format nil "ws.send('E:~A-')" hook)) + (setf (gethash hook (connection-data obj)) handler)) + (t + (remhash hook (connection-data obj)))))) + +(defgeneric set-on-click (clog-obj on-click-handler) + (:documentation "Set the ON-CLICK-HANDLER for CLOG-OBJ. If ON-CLICK-HANDLER +is nil unbind the event.")) + +(defmethod set-on-click ((obj clog-obj) on-click-handler) + (set-event obj "click" on-click-handler)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Implementation - clog diff --git a/test/test-clog.lisp b/test/test-clog.lisp index a9f1bc0..070c668 100644 --- a/test/test-clog.lisp +++ b/test/test-clog.lisp @@ -15,9 +15,10 @@ (when (equal (property tmp "draggable") (setf (property tmp "innerHTML") "

I am draggable

"))) (setf tmp (create-child win "")))) (defun test ()