mirror of
https://github.com/rabbibotton/clog.git
synced 2026-02-06 07:42:01 -08:00
add with-sync-event to populate functions
This commit is contained in:
David Botton
parent
77c4d96c55
commit
aa281fbf43
1 changed files with 178 additions and 178 deletions
|
|
@ -178,12 +178,12 @@
|
|||
(place-after control (get-placer control)))
|
||||
(get-control-list app panel-id))
|
||||
snap))
|
||||
|
||||
|
||||
|
||||
(defun save-panel (fname content panel-id hide-loc)
|
||||
"Save panel to FNAME"
|
||||
(write-file (panel-snap-shot content panel-id hide-loc) fname))
|
||||
|
||||
|
||||
;; Template Utilities
|
||||
|
||||
(defun walk-files-and-directories (path process)
|
||||
|
|
@ -754,13 +754,13 @@ not a temporary attached one when using select-control."
|
|||
(let ((attr (format nil "data-~A" (getf event :name))))
|
||||
(push `(,(getf event :name)
|
||||
,(let ((txt (attribute control attr)))
|
||||
(if (equalp txt "undefined")
|
||||
(if (equalp txt "undefined")
|
||||
""
|
||||
txt))
|
||||
,(getf event :parameters)
|
||||
,(getf event :setup)
|
||||
,(lambda (obj)
|
||||
(let ((txt (text-value obj)))
|
||||
(let ((txt (text-value obj)))
|
||||
(if (or (equal txt "")
|
||||
(equalp txt "undefined"))
|
||||
(remove-attribute control attr)
|
||||
|
|
@ -785,193 +785,197 @@ not a temporary attached one when using select-control."
|
|||
(setf (text-value editor) (second item))
|
||||
(set-on-blur editor
|
||||
(lambda (obj)
|
||||
(declare (ignore obj))
|
||||
(funcall (fifth item) obj)
|
||||
(jquery-execute control "trigger('clog-builder-snap-shot')")))))))))
|
||||
|
||||
(defun on-populate-control-properties-win (obj &key win)
|
||||
"Populate the control properties for the current control"
|
||||
;; obj if current-control is nil must be content
|
||||
(let ((app (connection-data-item obj "builder-app-data")))
|
||||
(on-populate-control-events-win obj)
|
||||
(let* ((prop-win (control-properties-win app))
|
||||
(control (if (current-control app)
|
||||
(current-control app)
|
||||
obj))
|
||||
(placer (when control
|
||||
(get-placer control)))
|
||||
(table (properties-list app)))
|
||||
(when prop-win
|
||||
(setf (inner-html table) "")
|
||||
(let ((info (control-info (attribute control "data-clog-type")))
|
||||
props)
|
||||
(dolist (prop (reverse (getf info :properties)))
|
||||
(cond ((eq (third prop) :style)
|
||||
(push `(,(getf prop :name) ,(style control (getf prop :style)) ,(getf prop :setup)
|
||||
(with-sync-event (obj)
|
||||
(let ((app (connection-data-item obj "builder-app-data")))
|
||||
(on-populate-control-events-win obj)
|
||||
(let* ((prop-win (control-properties-win app))
|
||||
(control (if (current-control app)
|
||||
(current-control app)
|
||||
obj))
|
||||
(placer (when control
|
||||
(get-placer control)))
|
||||
(table (properties-list app)))
|
||||
(when prop-win
|
||||
(setf (inner-html table) "")
|
||||
(let ((info (control-info (attribute control "data-clog-type")))
|
||||
props)
|
||||
(dolist (prop (reverse (getf info :properties)))
|
||||
(cond ((eq (third prop) :style)
|
||||
(push `(,(getf prop :name) ,(style control (getf prop :style)) ,(getf prop :setup)
|
||||
,(lambda (obj)
|
||||
(setf (style control (getf prop :style)) (text obj))))
|
||||
props))
|
||||
((or (eq (third prop) :get)
|
||||
(eq (third prop) :set)
|
||||
(eq (third prop) :setup))
|
||||
(push `(,(getf prop :name) ,(when (getf prop :get)
|
||||
(funcall (getf prop :get) control))
|
||||
,(getf prop :setup)
|
||||
,(lambda (obj)
|
||||
(when (getf prop :set)
|
||||
(funcall (getf prop :set) control obj))))
|
||||
props))
|
||||
((eq (third prop) :setf)
|
||||
(push `(,(getf prop :name) ,(funcall (getf prop :setf) control) ,(getf prop :setup)
|
||||
,(lambda (obj)
|
||||
(funcall (find-symbol (format nil "SET-~A" (getf prop :setf)) :clog) control (text obj))))
|
||||
props))
|
||||
((eq (third prop) :prop)
|
||||
(push `(,(getf prop :name) ,(property control (getf prop :prop)) ,(getf prop :setup)
|
||||
,(lambda (obj)
|
||||
(setf (property control (getf prop :prop)) (text obj))))
|
||||
props))
|
||||
((eq (third prop) :attr)
|
||||
(push `(,(getf prop :name) ,(attribute control (getf prop :attr)) ,(getf prop :setup)
|
||||
,(lambda (obj)
|
||||
(setf (attribute control (getf prop :attr)) (text obj))))
|
||||
props))
|
||||
(t (print "Configuration error."))))
|
||||
(when (current-control app)
|
||||
(push
|
||||
`("parent" ,(attribute (parent-element control) "data-clog-name")
|
||||
nil
|
||||
,(lambda (obj)
|
||||
(setf (style control (getf prop :style)) (text obj))))
|
||||
props))
|
||||
((or (eq (third prop) :get)
|
||||
(eq (third prop) :set)
|
||||
(eq (third prop) :setup))
|
||||
(push `(,(getf prop :name) ,(when (getf prop :get)
|
||||
(funcall (getf prop :get) control))
|
||||
,(getf prop :setup)
|
||||
,(lambda (obj)
|
||||
(when (getf prop :set)
|
||||
(funcall (getf prop :set) control obj))))
|
||||
props))
|
||||
((eq (third prop) :setf)
|
||||
(push `(,(getf prop :name) ,(funcall (getf prop :setf) control) ,(getf prop :setup)
|
||||
,(lambda (obj)
|
||||
(funcall (find-symbol (format nil "SET-~A" (getf prop :setf)) :clog) control (text obj))))
|
||||
props))
|
||||
((eq (third prop) :prop)
|
||||
(push `(,(getf prop :name) ,(property control (getf prop :prop)) ,(getf prop :setup)
|
||||
,(lambda (obj)
|
||||
(setf (property control (getf prop :prop)) (text obj))))
|
||||
props))
|
||||
((eq (third prop) :attr)
|
||||
(push `(,(getf prop :name) ,(attribute control (getf prop :attr)) ,(getf prop :setup)
|
||||
,(lambda (obj)
|
||||
(setf (attribute control (getf prop :attr)) (text obj))))
|
||||
props))
|
||||
(t (print "Configuration error."))))
|
||||
(when (current-control app)
|
||||
(place-inside-bottom-of
|
||||
(attach-as-child control
|
||||
(js-query
|
||||
control
|
||||
(format nil "$(\"[data-clog-name='~A']\").attr('id')"
|
||||
(text obj))))
|
||||
control)
|
||||
(place-after control placer)))
|
||||
props))
|
||||
(push
|
||||
`("parent" ,(attribute (parent-element control) "data-clog-name")
|
||||
`("name" ,(attribute control "data-clog-name")
|
||||
nil
|
||||
,(lambda (obj)
|
||||
(place-inside-bottom-of
|
||||
(attach-as-child control
|
||||
(js-query
|
||||
control
|
||||
(format nil "$(\"[data-clog-name='~A']\").attr('id')"
|
||||
(text obj))))
|
||||
control)
|
||||
(place-after control placer)))
|
||||
props))
|
||||
(push
|
||||
`("name" ,(attribute control "data-clog-name")
|
||||
nil
|
||||
,(lambda (obj)
|
||||
(setf (attribute control "data-clog-name") (text obj))
|
||||
(when (equal (getf info :name) "clog-data")
|
||||
(setf (window-title win) (text obj)))))
|
||||
props)
|
||||
(dolist (item props)
|
||||
(let* ((tr (create-table-row table))
|
||||
(td1 (create-table-column tr :content (first item)))
|
||||
(td2 (if (second item)
|
||||
(create-table-column tr :content (second item))
|
||||
(create-table-column tr))))
|
||||
(setf (width td1) "30%")
|
||||
(setf (width td2) "70%")
|
||||
(setf (spellcheckp td2) nil)
|
||||
(set-border td1 "1px" :dotted :black)
|
||||
(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)
|
||||
(jquery-execute control "trigger('clog-builder-snap-shot')")
|
||||
(when placer
|
||||
(set-geometry placer :top (position-top control)
|
||||
:left (position-left control)
|
||||
:width (client-width control)
|
||||
:height (client-height control))))))))))))
|
||||
(setf (attribute control "data-clog-name") (text obj))
|
||||
(when (equal (getf info :name) "clog-data")
|
||||
(setf (window-title win) (text obj)))))
|
||||
props)
|
||||
(dolist (item props)
|
||||
(let* ((tr (create-table-row table))
|
||||
(td1 (create-table-column tr :content (first item)))
|
||||
(td2 (if (second item)
|
||||
(create-table-column tr :content (second item))
|
||||
(create-table-column tr))))
|
||||
(setf (width td1) "30%")
|
||||
(setf (width td2) "70%")
|
||||
(setf (spellcheckp td2) nil)
|
||||
(set-border td1 "1px" :dotted :black)
|
||||
(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)
|
||||
(jquery-execute control "trigger('clog-builder-snap-shot')")
|
||||
(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)
|
||||
"Setup html imported in to CONTENT for use with Builder"
|
||||
(add-sub-controls content content :win win))
|
||||
(with-sync-event (content)
|
||||
(add-sub-controls content content :win win)))
|
||||
|
||||
(defun on-populate-control-list-win (content)
|
||||
"Populate the control-list-window to allow drag and drop adjust of order
|
||||
of controls and double click to select control."
|
||||
(let ((app (connection-data-item content "builder-app-data")))
|
||||
(let ((panel-id (html-id content))
|
||||
(last-ctl nil))
|
||||
(when (control-list-win app)
|
||||
(let ((win (control-list-win app)))
|
||||
(setf (inner-html win) "")
|
||||
(labels ((add-siblings (control sim)
|
||||
(let (dln dcc)
|
||||
(loop
|
||||
(when (equal (html-id control) "undefined") (return))
|
||||
(setf dcc (attribute control "data-clog-composite-control"))
|
||||
(setf dln (attribute control "data-clog-name"))
|
||||
(unless (equal dln "undefined")
|
||||
(let ((list-item (create-div win :content (format nil "↕ ~A~A" sim dln)))
|
||||
(status (hiddenp (get-placer control))))
|
||||
(if status
|
||||
(setf (color list-item) :darkred)
|
||||
(setf (background-color list-item) :grey))
|
||||
(setf (draggablep list-item) t)
|
||||
(setf (attribute list-item "data-clog-control") (html-id control))
|
||||
;; click to select item
|
||||
(set-on-mouse-down list-item
|
||||
(lambda (obj data)
|
||||
(let* ((html-id (attribute obj "data-clog-control"))
|
||||
(control (get-from-control-list app
|
||||
panel-id
|
||||
html-id)))
|
||||
(cond ((or (getf data :shift-key)
|
||||
(getf data :ctrl-key)
|
||||
(getf data :meta-key))
|
||||
(when (drop-new-control app content data)
|
||||
(incf-next-id content)))
|
||||
(t
|
||||
(when last-ctl
|
||||
(set-border last-ctl "0px" :dotted :blue))
|
||||
(set-border list-item "2px" :dotted :blue)
|
||||
(setf last-ctl list-item)
|
||||
(select-control control))))))
|
||||
(set-on-double-click list-item
|
||||
(lambda (obj)
|
||||
(with-sync-event (content)
|
||||
(let ((app (connection-data-item content "builder-app-data")))
|
||||
(let ((panel-id (html-id content))
|
||||
(last-ctl nil))
|
||||
(when (control-list-win app)
|
||||
(let ((win (control-list-win app)))
|
||||
(setf (inner-html win) "")
|
||||
(labels ((add-siblings (control sim)
|
||||
(let (dln dcc)
|
||||
(loop
|
||||
(when (equal (html-id control) "undefined") (return))
|
||||
(setf dcc (attribute control "data-clog-composite-control"))
|
||||
(setf dln (attribute control "data-clog-name"))
|
||||
(unless (equal dln "undefined")
|
||||
(let ((list-item (create-div win :content (format nil "↕ ~A~A" sim dln)))
|
||||
(status (hiddenp (get-placer control))))
|
||||
(if status
|
||||
(setf (color list-item) :darkred)
|
||||
(setf (background-color list-item) :grey))
|
||||
(setf (draggablep list-item) t)
|
||||
(setf (attribute list-item "data-clog-control") (html-id control))
|
||||
;; click to select item
|
||||
(set-on-mouse-down list-item
|
||||
(lambda (obj data)
|
||||
(let* ((html-id (attribute obj "data-clog-control"))
|
||||
(control (get-from-control-list app
|
||||
panel-id
|
||||
html-id))
|
||||
(placer (get-placer control))
|
||||
(state (hiddenp placer)))
|
||||
(setf (hiddenp placer) (not state))
|
||||
(select-control control)
|
||||
(on-populate-control-list-win content))))
|
||||
;; drag and drop to change
|
||||
(set-on-drag-over list-item (lambda (obj)(declare (ignore obj))()))
|
||||
(set-on-drop list-item
|
||||
(lambda (obj data)
|
||||
(let* ((id (attribute obj "data-clog-control"))
|
||||
(control1 (get-from-control-list app
|
||||
panel-id
|
||||
id))
|
||||
(control2 (get-from-control-list app
|
||||
panel-id
|
||||
(getf data :drag-data)))
|
||||
(placer1 (get-placer control1))
|
||||
(placer2 (get-placer control2)))
|
||||
(if (getf data :shift-key)
|
||||
(place-inside-bottom-of control1 control2)
|
||||
(place-before control1 control2))
|
||||
(place-after control2 placer2)
|
||||
(set-geometry placer1 :top (position-top control1)
|
||||
:left (position-left control1)
|
||||
:width (client-width control1)
|
||||
:height (client-height control1))
|
||||
(set-geometry placer2 :top (position-top control2)
|
||||
:left (position-left control2)
|
||||
:width (client-width control2)
|
||||
:height (client-height control2))
|
||||
(on-populate-control-properties-win content)
|
||||
(on-populate-control-list-win content))))
|
||||
(set-on-drag-start list-item (lambda (obj)(declare (ignore obj))())
|
||||
:drag-data (html-id control))
|
||||
(when (equal dcc "undefined") ; when t is not a composite control
|
||||
(add-siblings (first-child control) (format nil "~A→" sim)))))
|
||||
(setf control (next-sibling control))))))
|
||||
(add-siblings (first-child content) "")))))))
|
||||
html-id)))
|
||||
(cond ((or (getf data :shift-key)
|
||||
(getf data :ctrl-key)
|
||||
(getf data :meta-key))
|
||||
(when (drop-new-control app content data)
|
||||
(incf-next-id content)))
|
||||
(t
|
||||
(when last-ctl
|
||||
(set-border last-ctl "0px" :dotted :blue))
|
||||
(set-border list-item "2px" :dotted :blue)
|
||||
(setf last-ctl list-item)
|
||||
(select-control control))))))
|
||||
(set-on-double-click list-item
|
||||
(lambda (obj)
|
||||
(let* ((html-id (attribute obj "data-clog-control"))
|
||||
(control (get-from-control-list app
|
||||
panel-id
|
||||
html-id))
|
||||
(placer (get-placer control))
|
||||
(state (hiddenp placer)))
|
||||
(setf (hiddenp placer) (not state))
|
||||
(select-control control)
|
||||
(on-populate-control-list-win content))))
|
||||
;; drag and drop to change
|
||||
(set-on-drag-over list-item (lambda (obj)(declare (ignore obj))()))
|
||||
(set-on-drop list-item
|
||||
(lambda (obj data)
|
||||
(let* ((id (attribute obj "data-clog-control"))
|
||||
(control1 (get-from-control-list app
|
||||
panel-id
|
||||
id))
|
||||
(control2 (get-from-control-list app
|
||||
panel-id
|
||||
(getf data :drag-data)))
|
||||
(placer1 (get-placer control1))
|
||||
(placer2 (get-placer control2)))
|
||||
(if (getf data :shift-key)
|
||||
(place-inside-bottom-of control1 control2)
|
||||
(place-before control1 control2))
|
||||
(place-after control2 placer2)
|
||||
(set-geometry placer1 :top (position-top control1)
|
||||
:left (position-left control1)
|
||||
:width (client-width control1)
|
||||
:height (client-height control1))
|
||||
(set-geometry placer2 :top (position-top control2)
|
||||
:left (position-left control2)
|
||||
:width (client-width control2)
|
||||
:height (client-height control2))
|
||||
(on-populate-control-properties-win content)
|
||||
(on-populate-control-list-win content))))
|
||||
(set-on-drag-start list-item (lambda (obj)(declare (ignore obj))())
|
||||
:drag-data (html-id control))
|
||||
(when (equal dcc "undefined") ; when t is not a composite control
|
||||
(add-siblings (first-child control) (format nil "~A→" sim)))))
|
||||
(setf control (next-sibling control))))))
|
||||
(add-siblings (first-child content) ""))))))))
|
||||
|
||||
;; Menu handlers
|
||||
|
||||
|
|
@ -1023,7 +1027,7 @@ of controls and double click to select control."
|
|||
(set-geometry control-list :left 0 :top 0 :right 0)))
|
||||
|
||||
(defun on-show-control-events-win (obj)
|
||||
"Show control events window"
|
||||
"Show control events window"
|
||||
(let ((app (connection-data-item obj "builder-app-data")))
|
||||
(if (control-events-win app)
|
||||
(window-focus (control-events-win app))
|
||||
|
|
@ -1228,7 +1232,6 @@ of controls and double click to select control."
|
|||
(on-populate-loaded-window content :win win)
|
||||
(setf (window-title win) (attribute content "data-clog-name"))
|
||||
(on-populate-control-properties-win content :win win)
|
||||
(on-populate-control-events-win content)
|
||||
(on-populate-control-list-win content))))
|
||||
(set-on-event content "clog-builder-snap-shot"
|
||||
(lambda (obj)
|
||||
|
|
@ -1245,8 +1248,7 @@ of controls and double click to select control."
|
|||
(on-populate-loaded-window content :win win)
|
||||
(setf (window-title win) (attribute content "data-clog-name"))
|
||||
(on-populate-control-properties-win content :win win)
|
||||
(on-populate-control-events-win content)
|
||||
(on-populate-control-list-win content))))
|
||||
(on-populate-control-list-win content))))
|
||||
(set-on-click btn-load (lambda (obj)
|
||||
(server-file-dialog obj "Load Panel" file-name
|
||||
(lambda (fname)
|
||||
|
|
@ -1509,7 +1511,6 @@ of controls and double click to select control."
|
|||
(on-populate-loaded-window content :win win)
|
||||
(setf (window-title win) (attribute content "data-clog-name"))
|
||||
(on-populate-control-properties-win content :win win)
|
||||
(on-populate-control-events-win content)
|
||||
(on-populate-control-list-win content))))
|
||||
(set-on-event content "clog-builder-snap-shot"
|
||||
(lambda (obj)
|
||||
|
|
@ -1526,8 +1527,7 @@ of controls and double click to select control."
|
|||
(on-populate-loaded-window content :win win)
|
||||
(setf (window-title win) (attribute content "data-clog-name"))
|
||||
(on-populate-control-properties-win content :win win)
|
||||
(on-populate-control-events-win content)
|
||||
(on-populate-control-list-win content))))
|
||||
(on-populate-control-list-win content))))
|
||||
(set-on-click btn-load (lambda (obj)
|
||||
(declare (ignore obj))
|
||||
(server-file-dialog win "Load Panel" file-name
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue