diff --git a/source/clog-gui.lisp b/source/clog-gui.lisp index 4c56482..cde0a90 100644 --- a/source/clog-gui.lisp +++ b/source/clog-gui.lisp @@ -765,7 +765,7 @@ first menu-window-select will receive change window notices only.")) (set-on-mouse-enter window-select (lambda (obj) (refill obj)))))) (set-on-change window-select (lambda (obj) - (let ((win (gethash (value obj) (windows app)))) + (let ((win (gethash (text-value obj) (windows app)))) (when win (unless (keep-on-top win) (setf (hiddenp win) nil) @@ -1967,7 +1967,9 @@ result of on-input." :client-movement client-movement :html-id html-id)) (input (attach-as-child win (format nil "~A-input" html-id) - :clog-type 'clog:clog-form-element)) + :clog-type (if (eql rows 1) + `clog:clog-form-element + 'clog:clog-text-area))) (ok (attach-as-child win (format nil "~A-ok" html-id))) (cancel (attach-as-child win (format nil "~A-cancel" html-id)))) (unless top @@ -1986,13 +1988,14 @@ result of on-input." :one-time t) (set-on-click ok (lambda (obj) (declare (ignore obj)) - (set-on-window-close win nil) - (when modal - (window-end-modal win)) - (window-close win) - (setf result (funcall on-input (value input))) - (when sem - (bordeaux-threads:signal-semaphore sem))) + (let ((r (text-value input))) + (set-on-window-close win nil) + (when modal + (window-end-modal win)) + (window-close win) + (setf result (funcall on-input r)) + (when sem + (bordeaux-threads:signal-semaphore sem)))) :one-time t) (set-on-window-close win (lambda (obj) (declare (ignore obj)) @@ -2261,7 +2264,7 @@ on-input returned after either ok or cancel or time elapses." (declare (ignore obj)) (server-file-dialog body (first l) (fourth l) (lambda (fname) - (setf (value fld) fname)))))))) + (setf (text-value fld) fname)))))))) fields) (js-execute obj (format nil "$('[name=~A-~A]').focus()" html-id @@ -2372,9 +2375,9 @@ If time-out return result of on-file-name, cancels dialog if time runs out." (let ((dir (directory-namestring d))) (setf (inner-html dirs) "") (add-select-option dirs (format nil "~A" dir) ".") - (setf (value input) (if (equal fname "") - (truename dir) - (format nil "~A~A" (truename dir) fname))) + (setf (text-value input) (if (equal fname "") + (truename dir) + (format nil "~A~A" (truename dir) fname))) (unless (or (equalp dir "/") (equalp dir #P"/")) (add-select-option dirs (format nil "~A../" dir) "..")) (dolist (item (uiop:subdirectories dir)) @@ -2393,21 +2396,21 @@ If time-out return result of on-file-name, cancels dialog if time runs out." (populate-files initial-dir) (when initial-filename (ignore-errors - (setf (value input) (truename initial-filename))) + (setf (text-value input) (truename initial-filename))) (caret-at-end)) (set-on-change files (lambda (obj) (declare (ignore obj)) - (setf (value input) (truename (value files))) + (setf (text-value input) (truename (text-value files))) (caret-at-end))) (set-on-change dirs (lambda (obj) (declare (ignore obj)) - (setf (value input) (value dirs)) + (setf (text-value input) (text-value dirs)) (caret-at-end) - (populate-files (value dirs)))) + (populate-files (text-value dirs)))) (set-on-double-click dirs (lambda (obj) (declare (ignore obj)) - (populate-dirs (truename (value dirs))))) + (populate-dirs (truename (text-value dirs))))) (set-on-double-click files (lambda (obj) (declare (ignore obj)) (click ok)))) @@ -2428,7 +2431,7 @@ If time-out return result of on-file-name, cancels dialog if time runs out." (when modal (window-end-modal win)) (window-close win) - (setf result (funcall on-file-name (value input))) + (setf result (funcall on-file-name (text-value input))) (when sem (bordeaux-threads:signal-semaphore sem))) :one-time t) diff --git a/tools/clog-builder-control-list.lisp b/tools/clog-builder-control-list.lisp index d45e77d..cd17c6b 100644 --- a/tools/clog-builder-control-list.lisp +++ b/tools/clog-builder-control-list.lisp @@ -134,81 +134,90 @@ of controls and double click to select control." (deselect-current-control app) (on-populate-control-properties-win content :win win) (on-populate-control-list-win content :win win))) - (labels ((add-siblings (control sim) - (let (dln dcc) - (loop - (when (equalp (html-id control) "undefined") - (return)) - (setf dln (attribute control "data-clog-name")) - (unless (or (equal dln "undefined") - (eq dln nil)) - (setf dcc (attribute control "data-clog-composite-control")) - (let ((list-item (create-div lwin :content (format nil "↕ ~A~A" sim dln))) - (status (hiddenp (get-placer control)))) - (if status - (setf (color list-item) :darkred) - (setf (css-class-name list-item) *builder-pallete-class*)) - (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 ((dom (list-of-children content :no-attach t)) + dln) + (labels ((tr (control sim) + (if (equal (html-id control) "undefined") + (setf dln nil) + (setf dln (attribute control "data-clog-name"))) + (when (and dln + (not (equal dln "undefined"))) + (let ((list-item (create-div lwin :content (format nil "↕ ~A~A" + (format nil "~v@{~A~:*~}" sim "→") + dln))) + (status (hiddenp (get-placer control)))) + (if status + (setf (color list-item) :darkred) + (setf (css-class-name list-item) *builder-pallete-class*)) + (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) (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) - (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 :win win)))) - ;; 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 :win win) - (on-populate-control-list-win content :win win)))) - (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 :no-attach t) (format nil "~A→" sim))))) - (setf control (next-sibling control :no-attach t)))))) - (add-siblings (first-child content :no-attach t) "")))))))))) + html-id)) + (placer (get-placer control)) + (state (hiddenp placer))) + (setf (hiddenp placer) (not state)) + (select-control control) + (on-populate-control-list-win content :win win)))) + ;; 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 :win win) + (on-populate-control-list-win content :win win)))) + (set-on-drag-start list-item (lambda (obj)(declare (ignore obj))()) + :drag-data (html-id control))))) + (ll (lst sim) + (mapcar (lambda (l) + (if (listp l) + (if (and (not (listp (first l))) + (not (equal (attribute (first l) "data-clog-composite-control") + "undefined"))) + (tr (first l) sim) + (ll l (1+ sim))) + (tr l sim))) + lst))) + (ll dom -1))))))))))) + diff --git a/tools/clog-builder-panels.lisp b/tools/clog-builder-panels.lisp index b38eb54..57e0af9 100644 --- a/tools/clog-builder-panels.lisp +++ b/tools/clog-builder-panels.lisp @@ -460,20 +460,25 @@ not a temporarily attached one when using select-control." (unless (equalp name "undefined") (setf (attribute content "data-clog-name") name) (destroy data)))) - (labels ((add-siblings (control) - (let (dct) - (loop - (when (equal (html-id control) "undefined") (return)) + (let ((dom (list-of-children parent)) + dct) + (labels ((tr (control) + (unless (equal (html-id control) "undefined") (setf dct (attribute control "data-clog-type")) (unless (equal dct "undefined") - (change-class control (getf (control-info dct) :clog-type)) - (when (getf (control-info dct) :on-load) - (funcall (getf (control-info dct) :on-load) control (control-info dct))) - (setup-control content control :win win) - (unless (equal dct "block") - (add-siblings (first-child control)))) - (setf control (next-sibling control)))))) - (add-siblings (first-child parent))))) + (change-class control (getf (control-info dct) :clog-type))) + (when (getf (control-info dct) :on-load) + (funcall (getf (control-info dct) :on-load) control (control-info dct))) + (setup-control content control :win win))) + (ll (lst) + (mapcar (lambda (l) + (if (listp l) + (if (listp (first l)) + (tr (first l)) + (ll l)) + (tr l))) + lst))) + (ll dom))))) ;; Panel Windows