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

add eval for probe

Browse source
This commit is contained in:
David Botton 2024-06-06 17:31:48 -04:00
parent 8ba15a83b0
commit fef3180e23
2 changed files with 36 additions and 13 deletions
Download patch file Download diff file Expand all files Collapse all files

23
tools/clog-builder-probe.lisp
View file

@ -40,9 +40,26 @@
:width 300 :width 300
:has-pinner t :has-pinner t
:keep-on-top t :keep-on-top t
:client-movement *client-side-movement*))) :client-movement *client-side-movement*))
(create-div (window-content win) :style "left:0px;right:0px" :class "w3-tiny w3-center" (npanel (create-div (window-content win) :class "w3-small"))
:content "use CLOG-TOOL:CLOG-BUILDER-PROBE to add probes") (evaltxt (create-form-element npanel :text))
(pac-line (create-form-element npanel :text :value "clog-user")))
(setf (positioning evaltxt) :absolute)
(setf (positioning pac-line) :absolute)
(setf (height npanel) "57px")
(set-geometry evaltxt :height 27 :width "100%" :top 0 :left 0 :right 0)
(set-geometry pac-line :height 27 :width "100%" :top 27 :left 0 :right 0)
(setf (place-holder evaltxt) "Enter a form to evaluate to a probe")
(set-on-change evaltxt (lambda (obj)
(declare (ignore obj))
(let ((txt (text-value evaltxt)))
(when (not (equal txt ""))
(let* ((*package* (find-package (string-upcase (text-value pac-line))))
(aprobe (format nil "(clog-builder-probe ~A :title \"~A\")"
txt txt)))
(eval (read-from-string aprobe)))))))
(create-div (window-content win) :class "w3-tiny w3-center"
:content "or use CLOG-TOOL:CLOG-BUILDER-PROBE to add probes")
(setf (probe-win app) win) (setf (probe-win app) win)
(set-geometry win :top (menu-bar-height win) :left 0 :height "" :bottom 5 :right "") (set-geometry win :top (menu-bar-height win) :left 0 :height "" :bottom 5 :right "")
(set-on-window-move win (lambda (obj) (set-on-window-move win (lambda (obj)

26
tools/clog-builder-scope.lisp
View file

@ -10,11 +10,12 @@
:keep-on-top t :keep-on-top t
:client-movement *client-side-movement*)) :client-movement *client-side-movement*))
(root-obj (create-form-element (window-content win) :text)) (root-obj (create-form-element (window-content win) :text))
(pac-line (create-form-element (window-content win) :text :value "clog-user"))
class class
(tree (create-panel (window-content win) (tree (create-panel (window-content win)
:class "w3-small" :class "w3-small"
:overflow :scroll :overflow :scroll
:top 30 :bottom 0 :left 0 :right 0))) :top 60 :bottom 0 :left 0 :right 0)))
(set-on-click (create-span (window-icon-area win) (set-on-click (create-span (window-icon-area win)
:content (format nil "~A " (code-char #x26F6)) :content (format nil "~A " (code-char #x26F6))
:auto-place :top) :auto-place :top)
@ -29,11 +30,15 @@
(set-on-window-move win (lambda (obj) (set-on-window-move win (lambda (obj)
(setf (width obj) (width obj)) (setf (width obj) (width obj))
(setf (height obj) (height obj)))))) (setf (height obj) (height obj))))))
(if title (setf (place-holder root-obj) "Enter a form to evaluate")
(setf (text-value root-obj) title) (when object
(setf (text-value root-obj) (format nil "~a" object))) (if title
(setf (text-value root-obj) title)
(setf (text-value root-obj) (format nil "~a" object))))
(setf (positioning root-obj) :absolute) (setf (positioning root-obj) :absolute)
(setf (positioning pac-line) :absolute)
(set-geometry root-obj :height 27 :width "100%" :top 0 :left 0 :right 0) (set-geometry root-obj :height 27 :width "100%" :top 0 :left 0 :right 0)
(set-geometry pac-line :height 27 :width "100%" :top 27 :left 0 :right 0)
(labels ((escape-lisp (object) (labels ((escape-lisp (object)
(let ((value (format nil "~A" object))) (let ((value (format nil "~A" object)))
(setf value (ppcre:regex-replace-all "<" value "&lt;")) (setf value (ppcre:regex-replace-all "<" value "&lt;"))
@ -150,13 +155,12 @@
:on-context-menu (lambda (obj) :on-context-menu (lambda (obj)
(on-new-sys-browser obj (on-new-sys-browser obj
:search (get-name (closer-mop:slot-definition-name slot)))) :search (get-name (closer-mop:slot-definition-name slot))))
:fill-function (lambda (obj)
(let* ((object (slot-value object (closer-mop:slot-definition-name slot)))
(class (class-of object)))
(add-class obj class object)))
:content (format nil "<b>~A</b> Object Value = ~A" :content (format nil "<b>~A</b> Object Value = ~A"
(get-name (closer-mop:slot-definition-name slot)) (get-name (closer-mop:slot-definition-name slot))
(escape-lisp (slot-value object (closer-mop:slot-definition-name slot))))))) (escape-lisp (slot-value object (closer-mop:slot-definition-name slot)))))))
(let* ((object (slot-value object (closer-mop:slot-definition-name slot)))
(class (class-of object)))
(add-class sltt class object))
(create-clog-tree-item (tree-root sltt) (create-clog-tree-item (tree-root sltt)
:content (format nil "slot-definition-initargs = ~A" :content (format nil "slot-definition-initargs = ~A"
(escape-lisp (closer-mop:slot-definition-initargs slot)))) (escape-lisp (closer-mop:slot-definition-initargs slot))))
@ -186,5 +190,7 @@
(add-class tree class object))) (add-class tree class object)))
(set-on-change root-obj (lambda (obj) (set-on-change root-obj (lambda (obj)
(declare (ignore obj)) (declare (ignore obj))
(on-change (eval (read-from-string (text-value root-obj)))))) (on-change (let ((*package* (find-package (string-upcase (text-value pac-line)))))
(on-change object)))) (eval (read-from-string (text-value root-obj)))))))
(when object
(on-change object)))))