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

bulk traverse dom trees

Browse source
This commit is contained in:
David Botton 2024-06-24 14:02:35 -04:00
parent 0287d16884
commit dbfe0723ce
3 changed files with 123 additions and 106 deletions
Download patch file Download diff file Expand all files Collapse all files

41
source/clog-gui.lisp
View file

@ -765,7 +765,7 @@ first menu-window-select will receive change window notices only."))
(set-on-mouse-enter window-select (lambda (obj) (set-on-mouse-enter window-select (lambda (obj)
(refill obj)))))) (refill obj))))))
(set-on-change window-select (lambda (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 (when win
(unless (keep-on-top win) (unless (keep-on-top win)
(setf (hiddenp win) nil) (setf (hiddenp win) nil)
@ -1967,7 +1967,9 @@ result of on-input."
:client-movement client-movement :client-movement client-movement
:html-id html-id)) :html-id html-id))
(input (attach-as-child win (format nil "~A-input" 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))) (ok (attach-as-child win (format nil "~A-ok" html-id)))
(cancel (attach-as-child win (format nil "~A-cancel" html-id)))) (cancel (attach-as-child win (format nil "~A-cancel" html-id))))
(unless top (unless top
@ -1986,13 +1988,14 @@ result of on-input."
:one-time t) :one-time t)
(set-on-click ok (lambda (obj) (set-on-click ok (lambda (obj)
(declare (ignore obj)) (declare (ignore obj))
(set-on-window-close win nil) (let ((r (text-value input)))
(when modal (set-on-window-close win nil)
(window-end-modal win)) (when modal
(window-close win) (window-end-modal win))
(setf result (funcall on-input (value input))) (window-close win)
(when sem (setf result (funcall on-input r))
(bordeaux-threads:signal-semaphore sem))) (when sem
(bordeaux-threads:signal-semaphore sem))))
:one-time t) :one-time t)
(set-on-window-close win (lambda (obj) (set-on-window-close win (lambda (obj)
(declare (ignore obj)) (declare (ignore obj))
@ -2261,7 +2264,7 @@ on-input returned after either ok or cancel or time elapses."
(declare (ignore obj)) (declare (ignore obj))
(server-file-dialog body (first l) (fourth l) (server-file-dialog body (first l) (fourth l)
(lambda (fname) (lambda (fname)
(setf (value fld) fname)))))))) (setf (text-value fld) fname))))))))
fields) fields)
(js-execute obj (format nil "$('[name=~A-~A]').focus()" (js-execute obj (format nil "$('[name=~A-~A]').focus()"
html-id 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))) (let ((dir (directory-namestring d)))
(setf (inner-html dirs) "") (setf (inner-html dirs) "")
(add-select-option dirs (format nil "~A" dir) ".") (add-select-option dirs (format nil "~A" dir) ".")
(setf (value input) (if (equal fname "") (setf (text-value input) (if (equal fname "")
(truename dir) (truename dir)
(format nil "~A~A" (truename dir) fname))) (format nil "~A~A" (truename dir) fname)))
(unless (or (equalp dir "/") (equalp dir #P"/")) (unless (or (equalp dir "/") (equalp dir #P"/"))
(add-select-option dirs (format nil "~A../" dir) "..")) (add-select-option dirs (format nil "~A../" dir) ".."))
(dolist (item (uiop:subdirectories 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) (populate-files initial-dir)
(when initial-filename (when initial-filename
(ignore-errors (ignore-errors
(setf (value input) (truename initial-filename))) (setf (text-value input) (truename initial-filename)))
(caret-at-end)) (caret-at-end))
(set-on-change files (lambda (obj) (set-on-change files (lambda (obj)
(declare (ignore obj)) (declare (ignore obj))
(setf (value input) (truename (value files))) (setf (text-value input) (truename (text-value files)))
(caret-at-end))) (caret-at-end)))
(set-on-change dirs (lambda (obj) (set-on-change dirs (lambda (obj)
(declare (ignore obj)) (declare (ignore obj))
(setf (value input) (value dirs)) (setf (text-value input) (text-value dirs))
(caret-at-end) (caret-at-end)
(populate-files (value dirs)))) (populate-files (text-value dirs))))
(set-on-double-click dirs (set-on-double-click dirs
(lambda (obj) (lambda (obj)
(declare (ignore obj)) (declare (ignore obj))
(populate-dirs (truename (value dirs))))) (populate-dirs (truename (text-value dirs)))))
(set-on-double-click files (lambda (obj) (set-on-double-click files (lambda (obj)
(declare (ignore obj)) (declare (ignore obj))
(click ok)))) (click ok))))
@ -2428,7 +2431,7 @@ If time-out return result of on-file-name, cancels dialog if time runs out."
(when modal (when modal
(window-end-modal win)) (window-end-modal win))
(window-close win) (window-close win)
(setf result (funcall on-file-name (value input))) (setf result (funcall on-file-name (text-value input)))
(when sem (when sem
(bordeaux-threads:signal-semaphore sem))) (bordeaux-threads:signal-semaphore sem)))
:one-time t) :one-time t)

159
tools/clog-builder-control-list.lisp
View file

@ -134,81 +134,90 @@ of controls and double click to select control."
(deselect-current-control app) (deselect-current-control app)
(on-populate-control-properties-win content :win win) (on-populate-control-properties-win content :win win)
(on-populate-control-list-win content :win win))) (on-populate-control-list-win content :win win)))
(labels ((add-siblings (control sim) (let ((dom (list-of-children content :no-attach t))
(let (dln dcc) dln)
(loop (labels ((tr (control sim)
(when (equalp (html-id control) "undefined") (if (equal (html-id control) "undefined")
(return)) (setf dln nil)
(setf dln (attribute control "data-clog-name")) (setf dln (attribute control "data-clog-name")))
(unless (or (equal dln "undefined") (when (and dln
(eq dln nil)) (not (equal dln "undefined")))
(setf dcc (attribute control "data-clog-composite-control")) (let ((list-item (create-div lwin :content (format nil "↕ ~A~A"
(let ((list-item (create-div lwin :content (format nil "↕ ~A~A" sim dln))) (format nil "~v@{~A~:*~}" sim "→")
(status (hiddenp (get-placer control)))) dln)))
(if status (status (hiddenp (get-placer control))))
(setf (color list-item) :darkred) (if status
(setf (css-class-name list-item) *builder-pallete-class*)) (setf (color list-item) :darkred)
(setf (draggablep list-item) t) (setf (css-class-name list-item) *builder-pallete-class*))
(setf (attribute list-item "data-clog-control") (html-id control)) (setf (draggablep list-item) t)
;; click to select item (setf (attribute list-item "data-clog-control") (html-id control))
(set-on-mouse-down list-item ;; click to select item
(lambda (obj data) (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")) (let* ((html-id (attribute obj "data-clog-control"))
(control (get-from-control-list app (control (get-from-control-list app
panel-id panel-id
html-id))) html-id))
(cond ((or (getf data :shift-key) (placer (get-placer control))
(getf data :ctrl-key) (state (hiddenp placer)))
(getf data :meta-key)) (setf (hiddenp placer) (not state))
(when (drop-new-control app content data) (select-control control)
(incf-next-id content))) (on-populate-control-list-win content :win win))))
(t ;; drag and drop to change
(when last-ctl (set-on-drag-over list-item (lambda (obj)(declare (ignore obj))()))
(set-border last-ctl "0px" :dotted :blue)) (set-on-drop list-item
(set-border list-item "2px" :dotted :blue) (lambda (obj data)
(setf last-ctl list-item) (let* ((id (attribute obj "data-clog-control"))
(select-control control)))))) (control1 (get-from-control-list app
(set-on-double-click list-item panel-id
(lambda (obj) id))
(let* ((html-id (attribute obj "data-clog-control")) (control2 (get-from-control-list app
(control (get-from-control-list app panel-id
panel-id (getf data :drag-data)))
html-id)) (placer1 (get-placer control1))
(placer (get-placer control)) (placer2 (get-placer control2)))
(state (hiddenp placer))) (if (getf data :shift-key)
(setf (hiddenp placer) (not state)) (place-inside-bottom-of control1 control2)
(select-control control) (place-before control1 control2))
(on-populate-control-list-win content :win win)))) (place-after control2 placer2)
;; drag and drop to change (set-geometry placer1 :top (position-top control1)
(set-on-drag-over list-item (lambda (obj)(declare (ignore obj))())) :left (position-left control1)
(set-on-drop list-item :width (client-width control1)
(lambda (obj data) :height (client-height control1))
(let* ((id (attribute obj "data-clog-control")) (set-geometry placer2 :top (position-top control2)
(control1 (get-from-control-list app :left (position-left control2)
panel-id :width (client-width control2)
id)) :height (client-height control2))
(control2 (get-from-control-list app (on-populate-control-properties-win content :win win)
panel-id (on-populate-control-list-win content :win win))))
(getf data :drag-data))) (set-on-drag-start list-item (lambda (obj)(declare (ignore obj))())
(placer1 (get-placer control1)) :drag-data (html-id control)))))
(placer2 (get-placer control2))) (ll (lst sim)
(if (getf data :shift-key) (mapcar (lambda (l)
(place-inside-bottom-of control1 control2) (if (listp l)
(place-before control1 control2)) (if (and (not (listp (first l)))
(place-after control2 placer2) (not (equal (attribute (first l) "data-clog-composite-control")
(set-geometry placer1 :top (position-top control1) "undefined")))
:left (position-left control1) (tr (first l) sim)
:width (client-width control1) (ll l (1+ sim)))
:height (client-height control1)) (tr l sim)))
(set-geometry placer2 :top (position-top control2) lst)))
:left (position-left control2) (ll dom -1)))))))))))
: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) ""))))))))))

29
tools/clog-builder-panels.lisp
View file

@ -460,20 +460,25 @@ not a temporarily attached one when using select-control."
(unless (equalp name "undefined") (unless (equalp name "undefined")
(setf (attribute content "data-clog-name") name) (setf (attribute content "data-clog-name") name)
(destroy data)))) (destroy data))))
(labels ((add-siblings (control) (let ((dom (list-of-children parent))
(let (dct) dct)
(loop (labels ((tr (control)
(when (equal (html-id control) "undefined") (return)) (unless (equal (html-id control) "undefined")
(setf dct (attribute control "data-clog-type")) (setf dct (attribute control "data-clog-type"))
(unless (equal dct "undefined") (unless (equal dct "undefined")
(change-class control (getf (control-info dct) :clog-type)) (change-class control (getf (control-info dct) :clog-type)))
(when (getf (control-info dct) :on-load) (when (getf (control-info dct) :on-load)
(funcall (getf (control-info dct) :on-load) control (control-info dct))) (funcall (getf (control-info dct) :on-load) control (control-info dct)))
(setup-control content control :win win) (setup-control content control :win win)))
(unless (equal dct "block") (ll (lst)
(add-siblings (first-child control)))) (mapcar (lambda (l)
(setf control (next-sibling control)))))) (if (listp l)
(add-siblings (first-child parent))))) (if (listp (first l))
(tr (first l))
(ll l))
(tr l)))
lst)))
(ll dom)))))
;; Panel Windows ;; Panel Windows