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

better redirection of console to builder

Browse source
This commit is contained in:
David Botton 2024-04-14 23:34:31 -04:00
parent 9e6b8ce7e1
commit 11c19eedeb
4 changed files with 52 additions and 32 deletions
Download patch file Download diff file Expand all files Collapse all files

47
source/clog-gui.lisp
View file

@ -214,24 +214,28 @@
;; with-clog-debugger ;; ;; with-clog-debugger ;;
;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro with-clog-debugger ((clog-obj &key title) &body body) (defmacro with-clog-debugger ((clog-obj &key title standard-output) &body body)
"body uses a clog-gui based debugged instead of the console" "body uses a clog-gui based debugger instead of the console"
`(with-open-stream (out-stream (make-instance 'dialog-out-stream)) `(with-open-stream (out-stream (make-instance 'dialog-out-stream))
(with-open-stream (in-stream (make-instance 'dialog-in-stream :clog-obj ,clog-obj :source out-stream)) (with-open-stream (in-stream (make-instance 'dialog-in-stream :clog-obj ,clog-obj :source out-stream))
(labels ((my-debugger (condition encapsulation) (labels ((my-debugger (condition encapsulation)
(ignore-errors (handler-case
(let ((restart (one-of-dialog ,clog-obj condition (compute-restarts) (let ((restart (one-of-dialog ,clog-obj condition (compute-restarts)
:title (format nil "Available Restarts~A" :title (format nil "Available Restarts~A"
(if ,title (if ,title
(format nil " for ~A" ,title) (format nil " for ~A" ,title)
""))))) "")))))
(when restart (when restart
(let ((*debugger-hook* encapsulation)) (let ((*debugger-hook* encapsulation))
(invoke-restart-interactively restart))))))) (invoke-restart-interactively restart))))
(let* ((*query-io* (make-two-way-stream in-stream out-stream)) (end-of-file () ; no reset chosen
(*debugger-hook* (if clog-connection:*disable-clog-debugging* nil))))
*debugger-hook* (let* ((*standard-output* (or ,standard-output
#'my-debugger))) *standard-output*))
(*query-io* (make-two-way-stream in-stream out-stream))
(*debugger-hook* (if clog-connection:*disable-clog-debugging*
*debugger-hook*
#'my-debugger)))
,@body))))) ,@body)))))
;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
@ -242,6 +246,7 @@
(body-left-offset 0) (body-left-offset 0)
(body-right-offset 0) (body-right-offset 0)
(use-clog-debugger nil) (use-clog-debugger nil)
(standard-output nil)
(parent-desktop-obj nil) (parent-desktop-obj nil)
(w3-css-url "/css/w3.css") (w3-css-url "/css/w3.css")
(jquery-ui-css "/css/jquery-ui.css") (jquery-ui-css "/css/jquery-ui.css")
@ -272,9 +277,10 @@ NOTE: use-clog-debugger should not be set for security issues
(when jquery-ui (when jquery-ui
(load-script (html-document clog-body) jquery-ui)) (load-script (html-document clog-body) jquery-ui))
(when (and use-clog-debugger (not clog-connection:*disable-clog-debugging*)) (when (and use-clog-debugger (not clog-connection:*disable-clog-debugging*))
(setf (connection-data-item clog-body "clog-debug") (lambda (event data) (setf (connection-data-item clog-body "clog-debug")
(with-clog-debugger (clog-body) (lambda (event data)
(funcall event data)))))) (with-clog-debugger (clog-body :standard-output standard-output)
(funcall event data))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - Menus ;; Implementation - Menus
@ -1137,7 +1143,8 @@ window-to-top-by-param or window-by-param."))
(when (last-z app) (when (last-z app)
(setf (z-index obj) (incf (last-z app))))) (setf (z-index obj) (incf (last-z app)))))
(when (window-select app) (when (window-select app)
(setf (selectedp (window-select-item obj)) t)) (when (window-select-item obj)
(setf (selectedp (window-select-item obj)) t)))
(when pop (when pop
(focus pop)) (focus pop))
(fire-on-window-change obj app))) (fire-on-window-change obj app)))
@ -2282,7 +2289,7 @@ make-two-way-stream to provide a *query-io* using a clog-gui instead of console)
(with-output-to-string (s trc) (with-output-to-string (s trc)
(uiop:print-condition-backtrace intro :stream s)) (uiop:print-condition-backtrace intro :stream s))
(when trc (when trc
(format t "~A" trc))) (format t "~%~A~%" trc)))
(setf q (format nil "~A~&~A:" q prompt)) (setf q (format nil "~A~&~A:" q prompt))
(setq i (read-from-string (input-dialog obj q (lambda (result) (setq i (read-from-string (input-dialog obj q (lambda (result)
(cond ((or (eq result nil) (cond ((or (eq result nil)

12
tools/clog-builder-eval.lisp
View file

@ -3,12 +3,14 @@
(defun on-open-console (obj) (defun on-open-console (obj)
(let ((app (connection-data-item obj "builder-app-data"))) (let ((app (connection-data-item obj "builder-app-data")))
(if (console-win app) (if (console-win app)
(window-focus (console-win app)) (progn
(setf (hiddenp (console-win app)) nil)
(window-focus (console-win app)))
(let* ((win (on-open-file obj :title "CLOG Builder Console" (let* ((win (on-open-file obj :title "CLOG Builder Console"
:editor-use-console-for-evals t))) :editor-use-console-for-evals t)))
(set-on-window-close win (lambda (obj) (set-on-window-can-close win (lambda (obj)
(declare (ignore obj)) (setf (hiddenp obj) t)
(setf (console-win app) nil))) nil))
(setf (console-win app) win))))) (setf (console-win app) win)))))
;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;
@ -103,7 +105,7 @@ provide an interactive console.)"))
(when restart (when restart
(let ((*debugger-hook* encapsulation)) (let ((*debugger-hook* encapsulation))
(invoke-restart-interactively restart)))) (invoke-restart-interactively restart))))
(end-of-file () ; cancel was pressed (end-of-file () ; no reset chosen
(reset-ace))) (reset-ace)))
(format t "Error - ~A~%" condition)))) (format t "Error - ~A~%" condition))))
(unless (stringp form) (unless (stringp form)

12
tools/clog-builder-projects.lisp
View file

@ -55,11 +55,15 @@
(on-dir-win panel :dir (asdf:system-source-directory sys)))))) (on-dir-win panel :dir (asdf:system-source-directory sys))))))
(defun projects-run (panel) (defun projects-run (panel)
(let ((val (text-value (entry-point panel)))) (let ((app (connection-data-item panel "builder-app-data"))
(val (text-value (entry-point panel))))
(unless (equal val "") (unless (equal val "")
(setf clog:*clog-debug* (lambda (event data) (setf clog:*clog-debug*
(with-clog-debugger (panel :title val) (lambda (event data)
(funcall event data)))) (with-clog-debugger (panel
:title val
:standard-output (stdout app))
(funcall event data))))
(capture-eval (format nil "(~A)" val) :clog-obj panel (capture-eval (format nil "(~A)" val) :clog-obj panel
:capture-console nil :capture-console nil
:capture-result nil :capture-result nil

13
tools/clog-builder.lisp
View file

@ -24,7 +24,11 @@ clog-builder window.")
;; Per instance app data ;; Per instance app data
(defclass builder-app-data () (defclass builder-app-data ()
((copy-buf ((stdout
:accessor stdout
:initform nil
:documentation "The standard-output for this instance")
(copy-buf
:accessor copy-buf :accessor copy-buf
:initform nil :initform nil
:documentation "Copy buffer") :documentation "Copy buffer")
@ -316,9 +320,12 @@ clog-builder window.")
(open-ext (form-data-item (form-get-data body) "open-ext"))) (open-ext (form-data-item (form-get-data body) "open-ext")))
(setf (connection-data-item body "builder-app-data") app) (setf (connection-data-item body "builder-app-data") app)
(setf (title (html-document body)) "CLOG Builder") (setf (title (html-document body)) "CLOG Builder")
(clog-gui-initialize body :use-clog-debugger t) (setf (stdout app) (if clog-connection:*disable-clog-debugging*
*standard-output*
(make-instance 'console-out-stream :clog-obj body)))
(clog-gui-initialize body :use-clog-debugger t :standard-output (stdout app))
(add-class body *builder-window-desktop-class*) (add-class body *builder-window-desktop-class*)
(with-clog-debugger (body) (with-clog-debugger (body :standard-output (stdout app))
(when *builder-window-show-static-root-class* (when *builder-window-show-static-root-class*
(setf (z-index (create-panel body :positioning :fixed (setf (z-index (create-panel body :positioning :fixed
:bottom 0 :left 0 :bottom 0 :left 0