diff --git a/src/main.lisp b/src/main.lisp index 8c8fa91..f89f17d 100644 --- a/src/main.lisp +++ b/src/main.lisp @@ -47,6 +47,13 @@ (("load" #\l) :type string :list t :optional t :documentation "Read user code from file"))) +(defun print-backtrace (condition debug stream) + "Depending on DEBUG, print out the full backtrace or just a shorter + message on STREAM for given CONDITION." + (if debug + (trivial-backtrace:print-backtrace condition :output stream :verbose t) + (trivial-backtrace:print-condition condition stream))) + (defun main (argv) "Entry point when building an executable image with buildapp" (let ((args (rest argv))) @@ -86,43 +93,38 @@ do (load (compile-file filename :verbose nil :print nil)))) (when arguments + ;; Start the logs system + (let ((log-min-messages + (log-threshold log-min-messages + :quiet quiet :verbose verbose :debug debug)) + (client-min-messages + (log-threshold client-min-messages + :quiet quiet :verbose verbose :debug debug))) + + (start-logger :log-filename logfile + :log-min-messages log-min-messages + :client-min-messages client-min-messages)) + ;; process the files - (handler-case - ;; we bind here a catch-all handler to print out the backtrace - ;; before unwinding the call stack, so that it's a useful - ;; piece of information. - ;; - ;; we still need an handler-case to stop the processing in - ;; case of unhandled condition popping up here. - (handler-bind - ((condition - #'(lambda (condition) - (let ((s *standard-output*)) - (log-message :critical "Fatal error:") - (if debug - (trivial-backtrace:print-backtrace condition - :output s - :verbose t) - (trivial-backtrace:print-condition condition s)))))) - (loop for filename in arguments - do - (run-commands filename - :log-filename logfile - :log-min-messages - (log-threshold log-min-messages - :quiet quiet - :verbose verbose - :debug debug) - :client-min-messages - (log-threshold client-min-messages - :quiet quiet - :verbose verbose - :debug debug)) - (format t "~&"))) - (condition (c) - ;; avoid confronting users with the interactive debugger - ;; unless they asked for it using the --debug switch. - (when debug - (invoke-debugger c))))) + (loop for filename in arguments + do + ;; The handler-case is to catch unhandled exceptions at the + ;; top level and continue with the next file in the list. + ;; + ;; The handler-bind is to be able to offer a meaningful + ;; backtrace to the user in case of unexpected conditions + ;; being signaled. + (handler-case + (handler-bind + ((condition + #'(lambda (condition) + (log-message :fatal "We have a situation here.") + (print-backtrace condition debug *standard-output*)))) + + (run-commands filename :start-logger nil) + (format t "~&")) + + (condition (c) + (when debug (invoke-debugger c)))))) (uiop:quit))))) diff --git a/src/parser.lisp b/src/parser.lisp index f67a17b..e3caae8 100644 --- a/src/parser.lisp +++ b/src/parser.lisp @@ -1793,6 +1793,7 @@ load database (defun run-commands (source &key + (start-logger t) ((:log-filename *log-filename*) *log-filename*) ((:log-min-messages *log-min-messages*) *log-min-messages*) ((:client-min-messages *client-min-messages*) *client-min-messages*)) @@ -1800,9 +1801,10 @@ load database code then run, a pathname containing one or more commands that are parsed then run, or a commands string that is then parsed and each command run." - (start-logger :log-filename *log-filename* - :log-min-messages *log-min-messages* - :client-min-messages *client-min-messages*) + (when start-logger + (start-logger :log-filename *log-filename* + :log-min-messages *log-min-messages* + :client-min-messages *client-min-messages*)) (let* ((funcs (typecase source @@ -1821,8 +1823,9 @@ load database ;; run the commands (loop for func in funcs do (funcall func)) - ;; close the logs - (stop-logger))) + ;; close the logger, only when we've been tasked with opening it. + (when start-logger + (stop-logger)))) ;;; diff --git a/src/utils.lisp b/src/utils.lisp index 9407c93..f2488ea 100644 --- a/src/utils.lisp +++ b/src/utils.lisp @@ -52,7 +52,6 @@ (loop for messenger = (pop *log-messengers*) while messenger - unless (string= "stdout" (cl-log:messenger-name messenger)) do (cl-log:stop-messenger messenger))) ;; monkey patch the print-object method for cl-log timestamp