mirrors/clog
1
Fork 0
mirror of https://github.com/rabbibotton/clog.git synced 2025-12-12 13:40:23 -08:00
Code Issues Projects Releases Wiki Activity

syncing of property and event access

Browse source
This commit is contained in:
David Botton 2022-01-30 16:03:40 -05:00
parent 9f5d1b9df7
commit e96960a2c3
1 changed files with 131 additions and 111 deletions
Download patch file Download diff file Expand all files Collapse all files

62
tools/clog-builder.lisp
View file

@ -26,22 +26,22 @@
:accessor select-tool :accessor select-tool
:initform nil :initform nil
:documentation "Select tool") :documentation "Select tool")
(control-lists
:accessor control-lists
:initform (make-hash-table :test #'equalp)
:documentation "Panel to Control List hash table")
(properties-list (properties-list
:accessor properties-list :accessor properties-list
:initform nil :initform nil
:documentation "Property list in properties window") :documentation "Property list in properties window")
(control-properties-win
:accessor control-properties-win
:initform nil
:documentation "Current control properties window")
(events-list (events-list
:accessor events-list :accessor events-list
:initform nil :initform nil
:documentation "Property list in events window") :documentation "Property list in events window")
(properties-lock
:accessor properties-lock
:initform (bordeaux-threads:make-lock)
:documentation "Sync properties and event list")
(control-properties-win
:accessor control-properties-win
:initform nil
:documentation "Current control properties window")
(control-events-win (control-events-win
:accessor control-events-win :accessor control-events-win
:initform nil :initform nil
@ -53,18 +53,29 @@
(control-pallete-win (control-pallete-win
:accessor control-pallete-win :accessor control-pallete-win
:initform nil :initform nil
:documentation "Current control pallete window"))) :documentation "Current control pallete window")
(control-lists
:accessor control-lists
:initform (make-hash-table :test #'equalp)
:documentation "Panel to Control List hash table")
(control-lists-lock
:accessor control-lists-lock
:initform (bordeaux-threads:make-lock)
:documentation "Protect the control list")))
;; Cross page syncing ;; Cross page syncing
(defparameter *app-sync-hash* (make-hash-table :test #'equal) (defvar *app-sync-hash* (make-hash-table :test #'equal)
"Exchange app instance with new external pages") "Exchange app instance with new external pages")
(defvar *app-sync-lock* (bordeaux-threads:make-lock)
"Protect app-sync hash tables")
;; Control-List utilities ;; Control-List utilities
(defun init-control-list (app panel-id) (defun init-control-list (app panel-id)
"Initialize new control list for PANEL-ID on instance of APP." "Initialize new control list for PANEL-ID on instance of APP."
(setf (gethash panel-id (control-lists app)) (make-hash-table :test #'equalp))) (bordeaux-threads:with-lock-held ((control-lists-lock app))
(setf (gethash panel-id (control-lists app)) (make-hash-table :test #'equalp))))
(defun destroy-control-list (app panel-id) (defun destroy-control-list (app panel-id)
"Destroy the control-list on PANEL-ID" "Destroy the control-list on PANEL-ID"
@ -76,8 +87,9 @@
(defun add-to-control-list (app panel-id control) (defun add-to-control-list (app panel-id control)
"Add a CONTROL on to control-list on PANEL-ID" "Add a CONTROL on to control-list on PANEL-ID"
(bordeaux-threads:with-lock-held ((control-lists-lock app))
(let ((html-id (format nil "~A" (html-id control)))) (let ((html-id (format nil "~A" (html-id control))))
(setf (gethash html-id (get-control-list app panel-id)) control))) (setf (gethash html-id (get-control-list app panel-id)) control))))
(defun get-from-control-list (app panel-id html-id) (defun get-from-control-list (app panel-id html-id)
"Get control identified my HTML-ID from control-list on PANEL-ID" "Get control identified my HTML-ID from control-list on PANEL-ID"
@ -85,7 +97,8 @@
(defun remove-from-control-list (app panel-id html-id) (defun remove-from-control-list (app panel-id html-id)
"Remove a control identified by HTML-ID from control-list on PANEL-ID" "Remove a control identified by HTML-ID from control-list on PANEL-ID"
(remhash html-id (get-control-list app panel-id))) (bordeaux-threads:with-lock-held ((control-lists-lock app))
(remhash html-id (get-control-list app panel-id))))
(defun remove-deleted-from-control-list (app panel-id) (defun remove-deleted-from-control-list (app panel-id)
"Remove any deleted control from control-list" "Remove any deleted control from control-list"
@ -450,9 +463,10 @@ not a temporary attached one when using select-control."
(defun on-populate-control-properties-win (obj &key win) (defun on-populate-control-properties-win (obj &key win)
"Populate the control properties for the current control" "Populate the control properties for the current control"
;; obj if current-control is nil must be content ;; obj if current-control is nil must be content
(let ((app (connection-data-item obj "builder-app-data")))
(bordeaux-threads:with-lock-held ((properties-lock app))
(on-populate-control-events-win obj) (on-populate-control-events-win obj)
(let* ((app (connection-data-item obj "builder-app-data")) (let* ((prop-win (control-properties-win app))
(prop-win (control-properties-win app))
(control (if (current-control app) (control (if (current-control app)
(current-control app) (current-control app)
obj)) obj))
@ -539,7 +553,7 @@ not a temporary attached one when using select-control."
(set-geometry placer :top (position-top control) (set-geometry placer :top (position-top control)
:left (position-left control) :left (position-left control)
:width (client-width control) :width (client-width control)
:height (client-height control))))))))))) :height (client-height control)))))))))))))
(defun on-populate-loaded-window (content &key win) (defun on-populate-loaded-window (content &key win)
"Setup html imported in to CONTENT for use with Builder" "Setup html imported in to CONTENT for use with Builder"
@ -988,10 +1002,12 @@ of controls and double click to select control."
(panel-id (html-id content))) (panel-id (html-id content)))
;; sync new window with app ;; sync new window with app
(setf (connection-data-item body "builder-app-data") app) (setf (connection-data-item body "builder-app-data") app)
(remhash panel-uid *app-sync-hash*) (bordeaux-threads:with-lock-held (*app-sync-lock*)
(remhash panel-uid *app-sync-hash*))
(funcall (gethash (format nil "~A-link" panel-uid) *app-sync-hash*) content) (funcall (gethash (format nil "~A-link" panel-uid) *app-sync-hash*) content)
(setf win (gethash (format nil "~A-win" panel-uid) *app-sync-hash*)) (setf win (gethash (format nil "~A-win" panel-uid) *app-sync-hash*))
(remhash (format nil "~A-win" panel-uid) *app-sync-hash*) (bordeaux-threads:with-lock-held (*app-sync-lock*)
(remhash (format nil "~A-win" panel-uid) *app-sync-hash*))
;; setup window and page ;; setup window and page
(setf-next-id content 1) (setf-next-id content 1)
@ -1195,14 +1211,18 @@ of controls and double click to select control."
(txt-link (create-div txt-area (txt-link (create-div txt-area
:content (format nil "<br><center>~A</center>" link))) :content (format nil "<br><center>~A</center>" link)))
content panel-id) content panel-id)
(setf (gethash panel-uid *app-sync-hash*) app) (bordeaux-threads:with-lock-held (*app-sync-lock*)
(setf (gethash (format nil "~A-win" panel-uid) *app-sync-hash*) win) (setf (gethash panel-uid *app-sync-hash*) app))
(bordeaux-threads:with-lock-held (*app-sync-lock*)
(setf (gethash (format nil "~A-win" panel-uid) *app-sync-hash*) win))
(bordeaux-threads:with-lock-held (*app-sync-lock*)
(setf (gethash (format nil "~A-link" panel-uid) *app-sync-hash*) (setf (gethash (format nil "~A-link" panel-uid) *app-sync-hash*)
(lambda (obj) (lambda (obj)
(setf content obj) (setf content obj)
(setf panel-id (html-id content)) (setf panel-id (html-id content))
(destroy txt-area) (destroy txt-area)
(remhash (format nil "~A-link" panel-uid) *app-sync-hash*))) (bordeaux-threads:with-lock-held (*app-sync-lock*)
(remhash (format nil "~A-link" panel-uid) *app-sync-hash*)))))
(unless url-launch (unless url-launch
(open-browser :url link)))) (open-browser :url link))))