mirrors/clog
1
Fork 0
mirror of https://github.com/rabbibotton/clog.git synced 2025-12-06 02:30:42 -08:00
Code Issues Projects Releases Wiki Activity

Add some locks to complete control creation

Browse source
This commit is contained in:
David Botton 2022-01-31 13:42:45 -05:00
parent 60b230ab0c
commit 5f7867ec66
1 changed files with 69 additions and 61 deletions
Download patch file Download diff file Expand all files Collapse all files

130
tools/clog-builder.lisp
View file

@ -58,6 +58,10 @@
:accessor control-pallete-win :accessor control-pallete-win
:initform nil :initform nil
:documentation "Current control pallete window") :documentation "Current control pallete window")
(new-control-lock
:accessor new-control-lock
:initform (bordeaux-threads:make-lock)
:documentation "Sync creating new controls")
(control-lists (control-lists
:accessor control-lists :accessor control-lists
:initform (make-hash-table :test #'equalp) :initform (make-hash-table :test #'equalp)
@ -243,44 +247,45 @@
(defun do-drop-new-control (app content data &key win custom-query) (defun do-drop-new-control (app content data &key win custom-query)
"Create new control droppend at event DATA on CONTENT of WIN)" "Create new control droppend at event DATA on CONTENT of WIN)"
;; create control ;; create control
(let* ((control-record (control-info (value (select-tool app)))) (bordeaux-threads:with-lock-held ((new-control-lock app))
(control-type-name (getf control-record :name)) (let* ((control-record (control-info (value (select-tool app))))
(positioning (if (getf data :ctrl-key) (control-type-name (getf control-record :name))
:static (positioning (if (getf data :ctrl-key)
:absolute)) :static
(parent (when (getf data :shift-key) :absolute))
(current-control app))) (parent (when (getf data :shift-key)
(control (create-control (if parent (current-control app)))
parent (control (create-control (if parent
content) parent
content content)
control-record content
(format nil "CLOGB~A~A" control-record
(get-universal-time) (format nil "CLOGB~A~A"
(next-id content)) (get-universal-time)
:custom-query custom-query))) (next-id content))
(cond (control :custom-query custom-query)))
;; panel directly clicked with a control type selected (cond (control
;; setup control ;; panel directly clicked with a control type selected
(setf (attribute control "data-clog-name") ;; setup control
(format nil "~A-~A" control-type-name (next-id content))) (setf (attribute control "data-clog-name")
(setf (value (select-tool app)) 0) (format nil "~A-~A" control-type-name (next-id content)))
(setf (box-sizing control) :content-box) (setf (value (select-tool app)) 0)
(setf (positioning control) positioning) (setf (box-sizing control) :content-box)
(set-geometry control (setf (positioning control) positioning)
:left (getf data :x) (set-geometry control
:top (getf data :y)) :left (getf data :x)
(setup-control content control :win win) :top (getf data :y))
(select-control control) (setup-control content control :win win)
(add-sub-controls control content :win win) (select-control control)
(on-populate-control-list-win content) (add-sub-controls control content :win win)
t) (on-populate-control-list-win content)
(t t)
;; panel directly clicked with select tool or no control type to add (t
(deselect-current-control app) ;; panel directly clicked with select tool or no control type to add
(on-populate-control-properties-win content :win win) (deselect-current-control app)
(on-populate-control-list-win content) (on-populate-control-properties-win content :win win)
nil)))) (on-populate-control-list-win content)
nil)))))
(defun setup-control (content control &key win) (defun setup-control (content control &key win)
"Setup CONTROL by creating pacer and setting up events for manipulation" "Setup CONTROL by creating pacer and setting up events for manipulation"
@ -345,11 +350,12 @@ access to it and allows manipulation of location, size etc of the control."
(setf (current-control app) nil))) (setf (current-control app) nil)))
(defun delete-current-control (app panel-id html-id) (defun delete-current-control (app panel-id html-id)
(remove-from-control-list app panel-id html-id) (bordeaux-threads:with-lock-held ((new-control-lock app))
(destroy (get-placer (current-control app))) (remove-from-control-list app panel-id html-id)
(destroy (current-control app)) (destroy (get-placer (current-control app)))
(setf (current-control app) nil) (destroy (current-control app))
(remove-deleted-from-control-list app panel-id)) (setf (current-control app) nil)
(remove-deleted-from-control-list app panel-id)))
(defun select-control (control) (defun select-control (control)
"Select CONTROL as the current control and highlight its placer. "Select CONTROL as the current control and highlight its placer.
@ -924,6 +930,7 @@ of controls and double click to select control."
(get-control-list app panel-id))))) (get-control-list app panel-id)))))
(set-on-click btn-paste (lambda (obj) (set-on-click btn-paste (lambda (obj)
(declare (ignore obj)) (declare (ignore obj))
(bordeaux-threads:with-lock-held ((new-control-lock app))
(when (copy-buf app) (when (copy-buf app)
(let ((control (create-control content content (let ((control (create-control content content
`(:name "custom" `(:name "custom"
@ -938,7 +945,7 @@ of controls and double click to select control."
(setup-control content control :win win) (setup-control content control :win win)
(select-control control) (select-control control)
(add-sub-controls control content :win win :paste t) (add-sub-controls control content :win win :paste t)
(on-populate-control-list-win content))))) (on-populate-control-list-win content))))))
(set-on-click btn-del (lambda (obj) (set-on-click btn-del (lambda (obj)
(declare (ignore obj)) (declare (ignore obj))
(when (current-control app) (when (current-control app)
@ -1078,10 +1085,10 @@ of controls and double click to select control."
(clog-web-initialize body :w3-css-url nil))) (clog-web-initialize body :w3-css-url nil)))
;; init builder ;; init builder
(init-control-list app panel-id) (init-control-list app panel-id)
(let* ((pbox (create-panel-box-layout (window-content win) (let* ((pbox (create-panel-box-layout (window-content win)
:left-width 0 :right-width 0 :left-width 0 :right-width 0
:top-height 30 :bottom-height 0)) :top-height 30 :bottom-height 0))
(tool-bar (top-panel pbox)) (tool-bar (top-panel pbox))
(btn-del (create-button tool-bar :content "Del")) (btn-del (create-button tool-bar :content "Del"))
(btn-copy (create-button tool-bar :content "Copy")) (btn-copy (create-button tool-bar :content "Copy"))
(btn-paste (create-button tool-bar :content "Paste")) (btn-paste (create-button tool-bar :content "Paste"))
@ -1119,21 +1126,22 @@ of controls and double click to select control."
(get-control-list app panel-id))))) (get-control-list app panel-id)))))
(set-on-click btn-paste (lambda (obj) (set-on-click btn-paste (lambda (obj)
(declare (ignore obj)) (declare (ignore obj))
(when (copy-buf app) (bordeaux-threads:with-lock-held ((new-control-lock app))
(let ((control (create-control content content (when (copy-buf app)
`(:name "custom" (let ((control (create-control content content
:clog-type clog:clog-element `(:name "custom"
:create clog:create-child :clog-type clog:clog-element
:create-type :paste) :create clog:create-child
(format nil "CLOGB~A" (get-universal-time)) :create-type :paste)
:custom-query (copy-buf app)))) (format nil "CLOGB~A" (get-universal-time))
(setf (attribute control "data-clog-name") :custom-query (copy-buf app))))
(format nil "~A-~A" "copy" (next-id content))) (setf (attribute control "data-clog-name")
(incf-next-id content) (format nil "~A-~A" "copy" (next-id content)))
(setup-control content control :win win) (incf-next-id content)
(select-control control) (setup-control content control :win win)
(add-sub-controls control content :win win :paste t) (select-control control)
(on-populate-control-list-win content))))) (add-sub-controls control content :win win :paste t)
(on-populate-control-list-win content))))))
(set-on-click btn-del (lambda (obj) (set-on-click btn-del (lambda (obj)
(declare (ignore obj)) (declare (ignore obj))
(when (current-control app) (when (current-control app)