mirror of
https://github.com/rabbibotton/clog.git
synced 2025-12-10 21:00:15 -08:00
syncing of property and event access
This commit is contained in:
David Botton
parent
9f5d1b9df7
commit
e96960a2c3
1 changed files with 131 additions and 111 deletions
|
|
@ -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"
|
||||||
(let ((html-id (format nil "~A" (html-id control))))
|
(bordeaux-threads:with-lock-held ((control-lists-lock app))
|
||||||
(setf (gethash html-id (get-control-list app panel-id)) control)))
|
(let ((html-id (format nil "~A" (html-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,96 +463,97 @@ 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
|
||||||
(on-populate-control-events-win obj)
|
(let ((app (connection-data-item obj "builder-app-data")))
|
||||||
(let* ((app (connection-data-item obj "builder-app-data"))
|
(bordeaux-threads:with-lock-held ((properties-lock app))
|
||||||
(prop-win (control-properties-win app))
|
(on-populate-control-events-win obj)
|
||||||
(control (if (current-control app)
|
(let* ((prop-win (control-properties-win app))
|
||||||
(current-control app)
|
(control (if (current-control app)
|
||||||
obj))
|
(current-control app)
|
||||||
(placer (when control
|
obj))
|
||||||
(get-placer control)))
|
(placer (when control
|
||||||
(table (properties-list app)))
|
(get-placer control)))
|
||||||
(when prop-win
|
(table (properties-list app)))
|
||||||
(setf (inner-html table) "")
|
(when prop-win
|
||||||
(let ((info (control-info (attribute control "data-clog-type")))
|
(setf (inner-html table) "")
|
||||||
props)
|
(let ((info (control-info (attribute control "data-clog-type")))
|
||||||
(dolist (prop (reverse (getf info :properties)))
|
props)
|
||||||
(cond ((eq (third prop) :style)
|
(dolist (prop (reverse (getf info :properties)))
|
||||||
(push `(,(getf prop :name) ,(style control (getf prop :style)) ,(getf prop :setup)
|
(cond ((eq (third prop) :style)
|
||||||
,(lambda (obj)
|
(push `(,(getf prop :name) ,(style control (getf prop :style)) ,(getf prop :setup)
|
||||||
(setf (style control (getf prop :style)) (text obj))))
|
,(lambda (obj)
|
||||||
props))
|
(setf (style control (getf prop :style)) (text obj))))
|
||||||
((or (eq (third prop) :get)
|
props))
|
||||||
(eq (third prop) :set)
|
((or (eq (third prop) :get)
|
||||||
(eq (third prop) :setup))
|
(eq (third prop) :set)
|
||||||
(push `(,(getf prop :name) ,(when (getf prop :get)
|
(eq (third prop) :setup))
|
||||||
(funcall (getf prop :get) control))
|
(push `(,(getf prop :name) ,(when (getf prop :get)
|
||||||
,(getf prop :setup)
|
(funcall (getf prop :get) control))
|
||||||
,(lambda (obj)
|
,(getf prop :setup)
|
||||||
(when (getf prop :set)
|
,(lambda (obj)
|
||||||
(funcall (getf prop :set) control obj))))
|
(when (getf prop :set)
|
||||||
props))
|
(funcall (getf prop :set) control obj))))
|
||||||
((eq (third prop) :setf)
|
props))
|
||||||
(push `(,(getf prop :name) ,(funcall (getf prop :setf) control) ,(getf prop :setup)
|
((eq (third prop) :setf)
|
||||||
,(lambda (obj)
|
(push `(,(getf prop :name) ,(funcall (getf prop :setf) control) ,(getf prop :setup)
|
||||||
(funcall (find-symbol (format nil "SET-~A" (getf prop :setf)) :clog) control (text obj))))
|
,(lambda (obj)
|
||||||
props))
|
(funcall (find-symbol (format nil "SET-~A" (getf prop :setf)) :clog) control (text obj))))
|
||||||
((eq (third prop) :prop)
|
props))
|
||||||
(push `(,(getf prop :name) ,(property control (getf prop :prop)) ,(getf prop :setup)
|
((eq (third prop) :prop)
|
||||||
,(lambda (obj)
|
(push `(,(getf prop :name) ,(property control (getf prop :prop)) ,(getf prop :setup)
|
||||||
(setf (property control (getf prop :prop)) (text obj))))
|
,(lambda (obj)
|
||||||
props))
|
(setf (property control (getf prop :prop)) (text obj))))
|
||||||
((eq (third prop) :attr)
|
props))
|
||||||
(push `(,(getf prop :name) ,(attribute control (getf prop :attr)) ,(getf prop :setup)
|
((eq (third prop) :attr)
|
||||||
,(lambda (obj)
|
(push `(,(getf prop :name) ,(attribute control (getf prop :attr)) ,(getf prop :setup)
|
||||||
(setf (attribute control (getf prop :attr)) (text obj))))
|
,(lambda (obj)
|
||||||
props))
|
(setf (attribute control (getf prop :attr)) (text obj))))
|
||||||
(t (print "Configuration error."))))
|
props))
|
||||||
(when (current-control app)
|
(t (print "Configuration error."))))
|
||||||
|
(when (current-control app)
|
||||||
|
(push
|
||||||
|
`("parent" ,(attribute (parent-element control) "data-clog-name")
|
||||||
|
nil
|
||||||
|
,(lambda (obj)
|
||||||
|
(place-inside-bottom-of
|
||||||
|
(attach-as-child control
|
||||||
|
(clog::js-query
|
||||||
|
control
|
||||||
|
(format nil "$(\"[data-clog-name='~A']\").attr('id')"
|
||||||
|
(text obj))))
|
||||||
|
control)
|
||||||
|
(place-after control placer)))
|
||||||
|
props))
|
||||||
(push
|
(push
|
||||||
`("parent" ,(attribute (parent-element control) "data-clog-name")
|
`("name" ,(attribute control "data-clog-name")
|
||||||
nil
|
nil
|
||||||
,(lambda (obj)
|
,(lambda (obj)
|
||||||
(place-inside-bottom-of
|
(setf (attribute control "data-clog-name") (text obj))
|
||||||
(attach-as-child control
|
(when (equal (getf info :name) "clog-data")
|
||||||
(clog::js-query
|
(setf (window-title win) (text obj)))))
|
||||||
control
|
props)
|
||||||
(format nil "$(\"[data-clog-name='~A']\").attr('id')"
|
(dolist (item props)
|
||||||
(text obj))))
|
(let* ((tr (create-table-row table))
|
||||||
control)
|
(td1 (create-table-column tr :content (first item)))
|
||||||
(place-after control placer)))
|
(td2 (if (second item)
|
||||||
props))
|
(create-table-column tr :content (second item))
|
||||||
(push
|
(create-table-column tr))))
|
||||||
`("name" ,(attribute control "data-clog-name")
|
(setf (width td1) "30%")
|
||||||
nil
|
(setf (width td2) "70%")
|
||||||
,(lambda (obj)
|
(setf (spellcheckp td2) nil)
|
||||||
(setf (attribute control "data-clog-name") (text obj))
|
(set-border td1 "1px" :dotted :black)
|
||||||
(when (equal (getf info :name) "clog-data")
|
(cond ((third item)
|
||||||
(setf (window-title win) (text obj)))))
|
(unless (eq (third item) :read-only)
|
||||||
props)
|
(setf (editablep td2) (funcall (third item) control td1 td2))))
|
||||||
(dolist (item props)
|
(t
|
||||||
(let* ((tr (create-table-row table))
|
(setf (editablep td2) t)))
|
||||||
(td1 (create-table-column tr :content (first item)))
|
(set-on-blur td2
|
||||||
(td2 (if (second item)
|
(lambda (obj)
|
||||||
(create-table-column tr :content (second item))
|
(funcall (fourth item) obj)
|
||||||
(create-table-column tr))))
|
(when placer
|
||||||
(setf (width td1) "30%")
|
(set-geometry placer :top (position-top control)
|
||||||
(setf (width td2) "70%")
|
:left (position-left control)
|
||||||
(setf (spellcheckp td2) nil)
|
:width (client-width control)
|
||||||
(set-border td1 "1px" :dotted :black)
|
:height (client-height control)))))))))))))
|
||||||
(cond ((third item)
|
|
||||||
(unless (eq (third item) :read-only)
|
|
||||||
(setf (editablep td2) (funcall (third item) control td1 td2))))
|
|
||||||
(t
|
|
||||||
(setf (editablep td2) t)))
|
|
||||||
(set-on-blur td2
|
|
||||||
(lambda (obj)
|
|
||||||
(funcall (fourth item) obj)
|
|
||||||
(when placer
|
|
||||||
(set-geometry placer :top (position-top control)
|
|
||||||
:left (position-left control)
|
|
||||||
:width (client-width 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))
|
||||||
(setf (gethash (format nil "~A-link" panel-uid) *app-sync-hash*)
|
(bordeaux-threads:with-lock-held (*app-sync-lock*)
|
||||||
(lambda (obj)
|
(setf (gethash (format nil "~A-win" panel-uid) *app-sync-hash*) win))
|
||||||
(setf content obj)
|
(bordeaux-threads:with-lock-held (*app-sync-lock*)
|
||||||
(setf panel-id (html-id content))
|
(setf (gethash (format nil "~A-link" panel-uid) *app-sync-hash*)
|
||||||
(destroy txt-area)
|
(lambda (obj)
|
||||||
(remhash (format nil "~A-link" panel-uid) *app-sync-hash*)))
|
(setf content obj)
|
||||||
|
(setf panel-id (html-id content))
|
||||||
|
(destroy txt-area)
|
||||||
|
(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))))
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue