diff --git a/tools/clog-builder.lisp b/tools/clog-builder.lisp index 03fd149..08441e5 100644 --- a/tools/clog-builder.lisp +++ b/tools/clog-builder.lisp @@ -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