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

27
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))
(let ((r (text-value input)))
(set-on-window-close win nil) (set-on-window-close win nil)
(when modal (when modal
(window-end-modal win)) (window-end-modal win))
(window-close win) (window-close win)
(setf result (funcall on-input (value input))) (setf result (funcall on-input r))
(when sem (when sem
(bordeaux-threads:signal-semaphore 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,7 +2375,7 @@ 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"/"))
@ -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)

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

@ -134,16 +134,17 @@ 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 "→")
dln)))
(status (hiddenp (get-placer control)))) (status (hiddenp (get-placer control))))
(if status (if status
(setf (color list-item) :darkred) (setf (color list-item) :darkred)
@ -207,8 +208,16 @@ of controls and double click to select control."
(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))))
(set-on-drag-start list-item (lambda (obj)(declare (ignore obj))()) (set-on-drag-start list-item (lambda (obj)(declare (ignore obj))())
:drag-data (html-id control)) :drag-data (html-id control)))))
(when (equal dcc "undefined") ; when t is not a composite control (ll (lst sim)
(add-siblings (first-child control :no-attach t) (format nil "~A→" sim))))) (mapcar (lambda (l)
(setf control (next-sibling control :no-attach t)))))) (if (listp l)
(add-siblings (first-child content :no-attach t) "")))))))))) (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)))))))))))

25
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