Loading dev/backtrace.lisp 0 → 100644 +123 −0 Original line number Diff line number Diff line (in-package #:trivial-backtrace) (setf (documentation 'print-backtrace-to-stream 'function) "Send a backtrace of the current error to stream. Stream is assumed to be an open writable file stream or a string-output-stream. Note that `print-backtrace-to-stream` will print a backtrace for whatever the Lisp deems to be the *current* error. ") (defun print-condition (condition stream) (format stream "~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%" condition)) (defun print-backtrace (error &key (output nil) (if-exists :append) (verbose nil)) "Send a backtrace for the error `error` to `output`. The keywords arguments are: * :output - where to send the output. This can be: * a string (which is assumed to designate a pathname) * an open stream * nil to indicate that the backtrace information should be returned as a string * if-exists - what to do if output designates a pathname and the pathname already exists. Defaults to :append. * verbose - if true, then a message about the backtrace is sent to \\*terminal-io\\*. Defaults to `nil`. If the `output` is nil, the returns the backtrace output as a string. Otherwise, returns nil. " (when verbose (print-condition error *terminal-io*)) (multiple-value-bind (stream close?) (typecase output (null (values (make-string-output-stream) nil)) (string (values (open output :if-exists if-exists :if-does-not-exist :create :direction :output) t)) (stream (values output nil))) (unwind-protect (progn (print-condition error stream) (format stream "~&Date/time: ~a" (date-time-string)) (terpri stream) (print-backtrace-to-stream stream) (terpri stream) (when (typep stream 'string-stream) (get-output-stream-string stream))) ;; cleanup (when close? (close stream))))) #+mcl (defun print-backtrace-to-stream (stream) (let ((*debug-io* stream)) (ccl:print-call-history :detailed-p nil))) #+allegro (defun print-backtrace-to-stream (stream) (with-standard-io-syntax (let ((*print-readably* nil) (*print-miser-width* 40) (*print-pretty* t) (tpl:*zoom-print-circle* t) (tpl:*zoom-print-level* nil) (tpl:*zoom-print-length* nil)) (cl:ignore-errors (let ((*terminal-io* stream) (*standard-output* stream)) (tpl:do-command "zoom" :from-read-eval-print-loop nil :count t :all t)))))) #+lispworks (defun print-backtrace-to-stream (stream) (let ((dbg::*debugger-stack* (dbg::grab-stack nil :how-many most-positive-fixnum)) (*debug-io* stream) (dbg:*debug-print-level* nil) (dbg:*debug-print-length* nil)) (dbg:bug-backtrace nil))) #+sbcl ;; determine how we're going to access the backtrace in the next ;; function (eval-when (:compile-toplevel :load-toplevel :execute) (when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug) (pushnew :hunchentoot-sbcl-debug-print-variable-alist *features*))) #+sbcl (defun print-backtrace-to-stream (stream) (let (#+:hunchentoot-sbcl-debug-print-variable-alist (sb-debug:*debug-print-variable-alist* (list* '(*print-level* . nil) '(*print-length* . nil) sb-debug:*debug-print-variable-alist*)) #-:hunchentoot-sbcl-debug-print-variable-alist (sb-debug:*debug-print-level* nil) #-:hunchentoot-sbcl-debug-print-variable-alist (sb-debug:*debug-print-length* nil)) (sb-debug:backtrace most-positive-fixnum stream))) #+clisp (defun print-backtrace-to-stream (stream) (system::print-backtrace :out stream)) #+(or cmucl scl) (defun print-backtrace-to-stream (stream) (let ((debug:*debug-print-level* nil) (debug:*debug-print-length* nil)) (debug:backtrace most-positive-fixnum stream))) dev/packages.lisp +3 −1 Original line number Diff line number Diff line Loading @@ -3,5 +3,7 @@ (defpackage #:trivial-backtrace (:use #:common-lisp) (:export #:print-backtrace #:print-backtrace-to-stream)) #:print-backtrace-to-stream #:print-condition #:*date-time-format*)) dev/utilities.lisp +100 −111 Original line number Diff line number Diff line (in-package #:trivial-backtrace) (setf (documentation 'print-backtrace-to-stream 'function) "Send a backtrace of the current error to stream. (defparameter *date-time-format* "%Y-%m-%d-%H:%M") Stream is assumed to be an open writable file stream or a string-output-stream. Note that `print-backtrace-to-stream` will print a backtrace for whatever the Lisp deems to be the *current* error. ") (defun print-backtrace (error &key (output nil) (if-exists :append) (verbose nil)) "Send a backtrace for the error `error` to `output`. The keywords arguments are: * :output - where to send the output. This can be: * a string (which is assumed to designate a pathname) * an open stream * nil to indicate that the backtrace information should be returned as a string * if-exists - what to do if output designates a pathname and the pathname already exists. Defaults to :append. * verbose - if true, then a message about the backtrace is sent to \\*terminal-io\\*. Defaults to `nil`. If the `output` is nil, the returns the backtrace output as a string. Otherwise, returns nil. ;; modified from metatilities-base (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro generate-time-part-function (part-name position) (let ((function-name (intern (concatenate 'string (symbol-name 'time) "-" (symbol-name part-name)) :trivial-backtrace))) `(eval-when (:compile-toplevel :load-toplevel :execute) (export ',function-name) (defun ,function-name (&optional (universal-time (get-universal-time)) (time-zone nil)) ,(format nil "Returns the ~(~A~) part of the given time." part-name) (nth-value ,position (apply #'decode-universal-time universal-time time-zone)))))) (generate-time-part-function second 0) (generate-time-part-function minute 1) (generate-time-part-function hour 2) (generate-time-part-function date 3) (generate-time-part-function month 4) (generate-time-part-function year 5) (generate-time-part-function day-of-week 6) (generate-time-part-function daylight-savings-time-p 7)) (defun date-time-string (&key (date/time (get-universal-time)) (format *date-time-format*)) (format-date format date/time nil)) (defun format-date (format date &optional stream time-zone) "Formats universal dates using the same format specifiers as NSDateFormatter. The format is: %% - A '%' character %d - Day of the month as a decimal number [01-31] %e - Same as %d but does not print the leading 0 for days 1 through 9 [unlike strftime[], does not print a leading space] %H - Hour based on a 24-hour clock as a decimal number [00-23] %I - Hour based on a 12-hour clock as a decimal number [01-12] %m - Month as a decimal number [01-12] %M - Minute as a decimal number [00-59] %S - Second as a decimal number [00-59] %w - Weekday as a decimal number [0-6], where Sunday is 0 %y - Year without century [00-99] %Y - Year with century [such as 1990] " (when verbose (declare (ignore time-zone)) (let ((format-length (length format))) (format *terminal-io* "~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%" error)) (multiple-value-bind (output close?) (typecase output (null (values (make-string-output-stream) nil)) (string (values (open output :if-exists if-exists :if-does-not-exist :create :direction :output) t)) (stream (values output nil))) (unwind-protect (progn (print-backtrace-to-stream output) (when (typep output 'string-stream) (get-output-stream-string output))) ;; cleanup (when close? (close output))))) #+mcl (defun print-backtrace-to-stream (stream) (let ((*debug-io* stream)) (ccl:print-call-history :detailed-p nil))) #+allegro (defun print-backtrace-to-stream (stream) (with-standard-io-syntax (let ((*print-readably* nil) (*print-miser-width* 40) (*print-pretty* t) (tpl:*zoom-print-circle* t) (tpl:*zoom-print-level* nil) (tpl:*zoom-print-length* nil)) (cl:ignore-errors (let ((*terminal-io* stream) (*standard-output* stream)) (tpl:do-command "zoom" :from-read-eval-print-loop nil :count t :all t)))))) #+lispworks (defun print-backtrace-to-stream (stream) (let ((dbg::*debugger-stack* (dbg::grab-stack nil :how-many most-positive-fixnum)) (*debug-io* stream) (dbg:*debug-print-level* nil) (dbg:*debug-print-length* nil)) (dbg:bug-backtrace nil))) #+sbcl ;; determine how we're going to access the backtrace in the next ;; function (eval-when (:compile-toplevel :load-toplevel :execute) (when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug) (pushnew :hunchentoot-sbcl-debug-print-variable-alist *features*))) #+sbcl (defun print-backtrace-to-stream (stream) (let (#+:hunchentoot-sbcl-debug-print-variable-alist (sb-debug:*debug-print-variable-alist* (list* '(*print-level* . nil) '(*print-length* . nil) sb-debug:*debug-print-variable-alist*)) #-:hunchentoot-sbcl-debug-print-variable-alist (sb-debug:*debug-print-level* nil) #-:hunchentoot-sbcl-debug-print-variable-alist (sb-debug:*debug-print-length* nil)) (sb-debug:backtrace most-positive-fixnum stream))) #+clisp (defun print-backtrace-to-stream (stream) (system::print-backtrace :out stream)) #+(or cmucl scl) (defun print-backtrace-to-stream (stream) (let ((debug:*debug-print-level* nil) (debug:*debug-print-length* nil)) (debug:backtrace most-positive-fixnum stream))) stream "~{~A~}" (loop for index = 0 then (1+ index) while (< index format-length) collect (let ((char (aref format index))) (cond ((char= #\% char) (setf char (aref format (incf index))) (cond ;; %% - A '%' character ((char= char #\%) #\%) ;; %d - Day of the month as a decimal number [01-31] ((char= char #\d) (format nil "~2,'0D" (time-date date))) ;; %e - Same as %d but does not print the leading 0 for ;; days 1 through 9. Unlike strftime, does not print a ;; leading space ((char= char #\e) (format nil "~D" (time-date date))) ;; %H - Hour based on a 24-hour clock as a decimal number [00-23] ((char= char #\H) (format nil "~2,'0D" (time-hour date))) ;; %I - Hour based on a 12-hour clock as a decimal number [01-12] ((char= char #\I) (format nil "~2,'0D" (1+ (mod (time-hour date) 12)))) ;; %m - Month as a decimal number [01-12] ((char= char #\m) (format nil "~2,'0D" (time-month date))) ;; %M - Minute as a decimal number [00-59] ((char= char #\M) (format nil "~2,'0D" (time-minute date))) ;; %S - Second as a decimal number [00-59] ((char= char #\S) (format nil "~2,'0D" (time-second date))) ;; %w - Weekday as a decimal number [0-6], where Sunday is 0 ((char= char #\w) (format nil "~D" (time-day-of-week date))) ;; %y - Year without century [00-99] ((char= char #\y) (let ((year-string (format nil "~,2A" (time-year date)))) (subseq year-string (- (length year-string) 2)))) ;; %Y - Year with century [such as 1990] ((char= char #\Y) (format nil "~D" (time-year date))) (t (error "Ouch - unknown formatter '%~c" char)))) (t char))))))) lift-standard.config 0 → 100644 +35 −0 Original line number Diff line number Diff line ;;; configuration for LIFT tests ;; settings (:if-dribble-exists :supersede) (:dribble "lift.dribble") (:print-length 10) (:print-level 5) (:print-test-case-names t) ;; suites to run (docudown-test) ;; report properties (:report-property :title "DocuDown | Test results") (:report-property :relative-to docudown-test) (:report-property :style-sheet "test-style.css") (:report-property :if-exists :supersede) (:report-property :format :html) (:report-property :name "test-results/test-report.html") (:report-property :unique-name t) (:build-report) (:report-property :unique-name t) (:report-property :format :describe) (:report-property :name "test-results/test-report.txt") (:build-report) (:report-property :format :save) (:report-property :name "test-results/test-report.sav") (:build-report) (:report-property :format :describe) (:report-property :full-pathname *standard-output*) (:build-report) test/packages.lisp +1 −1 Original line number Diff line number Diff line (in-package #:common-lisp-user) (defpackage #:trivial-backtrace-test (:use #:common-lisp #:lift)) (:use #:common-lisp #:lift #:trivial-backtrace)) Loading
dev/backtrace.lisp 0 → 100644 +123 −0 Original line number Diff line number Diff line (in-package #:trivial-backtrace) (setf (documentation 'print-backtrace-to-stream 'function) "Send a backtrace of the current error to stream. Stream is assumed to be an open writable file stream or a string-output-stream. Note that `print-backtrace-to-stream` will print a backtrace for whatever the Lisp deems to be the *current* error. ") (defun print-condition (condition stream) (format stream "~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%" condition)) (defun print-backtrace (error &key (output nil) (if-exists :append) (verbose nil)) "Send a backtrace for the error `error` to `output`. The keywords arguments are: * :output - where to send the output. This can be: * a string (which is assumed to designate a pathname) * an open stream * nil to indicate that the backtrace information should be returned as a string * if-exists - what to do if output designates a pathname and the pathname already exists. Defaults to :append. * verbose - if true, then a message about the backtrace is sent to \\*terminal-io\\*. Defaults to `nil`. If the `output` is nil, the returns the backtrace output as a string. Otherwise, returns nil. " (when verbose (print-condition error *terminal-io*)) (multiple-value-bind (stream close?) (typecase output (null (values (make-string-output-stream) nil)) (string (values (open output :if-exists if-exists :if-does-not-exist :create :direction :output) t)) (stream (values output nil))) (unwind-protect (progn (print-condition error stream) (format stream "~&Date/time: ~a" (date-time-string)) (terpri stream) (print-backtrace-to-stream stream) (terpri stream) (when (typep stream 'string-stream) (get-output-stream-string stream))) ;; cleanup (when close? (close stream))))) #+mcl (defun print-backtrace-to-stream (stream) (let ((*debug-io* stream)) (ccl:print-call-history :detailed-p nil))) #+allegro (defun print-backtrace-to-stream (stream) (with-standard-io-syntax (let ((*print-readably* nil) (*print-miser-width* 40) (*print-pretty* t) (tpl:*zoom-print-circle* t) (tpl:*zoom-print-level* nil) (tpl:*zoom-print-length* nil)) (cl:ignore-errors (let ((*terminal-io* stream) (*standard-output* stream)) (tpl:do-command "zoom" :from-read-eval-print-loop nil :count t :all t)))))) #+lispworks (defun print-backtrace-to-stream (stream) (let ((dbg::*debugger-stack* (dbg::grab-stack nil :how-many most-positive-fixnum)) (*debug-io* stream) (dbg:*debug-print-level* nil) (dbg:*debug-print-length* nil)) (dbg:bug-backtrace nil))) #+sbcl ;; determine how we're going to access the backtrace in the next ;; function (eval-when (:compile-toplevel :load-toplevel :execute) (when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug) (pushnew :hunchentoot-sbcl-debug-print-variable-alist *features*))) #+sbcl (defun print-backtrace-to-stream (stream) (let (#+:hunchentoot-sbcl-debug-print-variable-alist (sb-debug:*debug-print-variable-alist* (list* '(*print-level* . nil) '(*print-length* . nil) sb-debug:*debug-print-variable-alist*)) #-:hunchentoot-sbcl-debug-print-variable-alist (sb-debug:*debug-print-level* nil) #-:hunchentoot-sbcl-debug-print-variable-alist (sb-debug:*debug-print-length* nil)) (sb-debug:backtrace most-positive-fixnum stream))) #+clisp (defun print-backtrace-to-stream (stream) (system::print-backtrace :out stream)) #+(or cmucl scl) (defun print-backtrace-to-stream (stream) (let ((debug:*debug-print-level* nil) (debug:*debug-print-length* nil)) (debug:backtrace most-positive-fixnum stream)))
dev/packages.lisp +3 −1 Original line number Diff line number Diff line Loading @@ -3,5 +3,7 @@ (defpackage #:trivial-backtrace (:use #:common-lisp) (:export #:print-backtrace #:print-backtrace-to-stream)) #:print-backtrace-to-stream #:print-condition #:*date-time-format*))
dev/utilities.lisp +100 −111 Original line number Diff line number Diff line (in-package #:trivial-backtrace) (setf (documentation 'print-backtrace-to-stream 'function) "Send a backtrace of the current error to stream. (defparameter *date-time-format* "%Y-%m-%d-%H:%M") Stream is assumed to be an open writable file stream or a string-output-stream. Note that `print-backtrace-to-stream` will print a backtrace for whatever the Lisp deems to be the *current* error. ") (defun print-backtrace (error &key (output nil) (if-exists :append) (verbose nil)) "Send a backtrace for the error `error` to `output`. The keywords arguments are: * :output - where to send the output. This can be: * a string (which is assumed to designate a pathname) * an open stream * nil to indicate that the backtrace information should be returned as a string * if-exists - what to do if output designates a pathname and the pathname already exists. Defaults to :append. * verbose - if true, then a message about the backtrace is sent to \\*terminal-io\\*. Defaults to `nil`. If the `output` is nil, the returns the backtrace output as a string. Otherwise, returns nil. ;; modified from metatilities-base (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro generate-time-part-function (part-name position) (let ((function-name (intern (concatenate 'string (symbol-name 'time) "-" (symbol-name part-name)) :trivial-backtrace))) `(eval-when (:compile-toplevel :load-toplevel :execute) (export ',function-name) (defun ,function-name (&optional (universal-time (get-universal-time)) (time-zone nil)) ,(format nil "Returns the ~(~A~) part of the given time." part-name) (nth-value ,position (apply #'decode-universal-time universal-time time-zone)))))) (generate-time-part-function second 0) (generate-time-part-function minute 1) (generate-time-part-function hour 2) (generate-time-part-function date 3) (generate-time-part-function month 4) (generate-time-part-function year 5) (generate-time-part-function day-of-week 6) (generate-time-part-function daylight-savings-time-p 7)) (defun date-time-string (&key (date/time (get-universal-time)) (format *date-time-format*)) (format-date format date/time nil)) (defun format-date (format date &optional stream time-zone) "Formats universal dates using the same format specifiers as NSDateFormatter. The format is: %% - A '%' character %d - Day of the month as a decimal number [01-31] %e - Same as %d but does not print the leading 0 for days 1 through 9 [unlike strftime[], does not print a leading space] %H - Hour based on a 24-hour clock as a decimal number [00-23] %I - Hour based on a 12-hour clock as a decimal number [01-12] %m - Month as a decimal number [01-12] %M - Minute as a decimal number [00-59] %S - Second as a decimal number [00-59] %w - Weekday as a decimal number [0-6], where Sunday is 0 %y - Year without century [00-99] %Y - Year with century [such as 1990] " (when verbose (declare (ignore time-zone)) (let ((format-length (length format))) (format *terminal-io* "~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%" error)) (multiple-value-bind (output close?) (typecase output (null (values (make-string-output-stream) nil)) (string (values (open output :if-exists if-exists :if-does-not-exist :create :direction :output) t)) (stream (values output nil))) (unwind-protect (progn (print-backtrace-to-stream output) (when (typep output 'string-stream) (get-output-stream-string output))) ;; cleanup (when close? (close output))))) #+mcl (defun print-backtrace-to-stream (stream) (let ((*debug-io* stream)) (ccl:print-call-history :detailed-p nil))) #+allegro (defun print-backtrace-to-stream (stream) (with-standard-io-syntax (let ((*print-readably* nil) (*print-miser-width* 40) (*print-pretty* t) (tpl:*zoom-print-circle* t) (tpl:*zoom-print-level* nil) (tpl:*zoom-print-length* nil)) (cl:ignore-errors (let ((*terminal-io* stream) (*standard-output* stream)) (tpl:do-command "zoom" :from-read-eval-print-loop nil :count t :all t)))))) #+lispworks (defun print-backtrace-to-stream (stream) (let ((dbg::*debugger-stack* (dbg::grab-stack nil :how-many most-positive-fixnum)) (*debug-io* stream) (dbg:*debug-print-level* nil) (dbg:*debug-print-length* nil)) (dbg:bug-backtrace nil))) #+sbcl ;; determine how we're going to access the backtrace in the next ;; function (eval-when (:compile-toplevel :load-toplevel :execute) (when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug) (pushnew :hunchentoot-sbcl-debug-print-variable-alist *features*))) #+sbcl (defun print-backtrace-to-stream (stream) (let (#+:hunchentoot-sbcl-debug-print-variable-alist (sb-debug:*debug-print-variable-alist* (list* '(*print-level* . nil) '(*print-length* . nil) sb-debug:*debug-print-variable-alist*)) #-:hunchentoot-sbcl-debug-print-variable-alist (sb-debug:*debug-print-level* nil) #-:hunchentoot-sbcl-debug-print-variable-alist (sb-debug:*debug-print-length* nil)) (sb-debug:backtrace most-positive-fixnum stream))) #+clisp (defun print-backtrace-to-stream (stream) (system::print-backtrace :out stream)) #+(or cmucl scl) (defun print-backtrace-to-stream (stream) (let ((debug:*debug-print-level* nil) (debug:*debug-print-length* nil)) (debug:backtrace most-positive-fixnum stream))) stream "~{~A~}" (loop for index = 0 then (1+ index) while (< index format-length) collect (let ((char (aref format index))) (cond ((char= #\% char) (setf char (aref format (incf index))) (cond ;; %% - A '%' character ((char= char #\%) #\%) ;; %d - Day of the month as a decimal number [01-31] ((char= char #\d) (format nil "~2,'0D" (time-date date))) ;; %e - Same as %d but does not print the leading 0 for ;; days 1 through 9. Unlike strftime, does not print a ;; leading space ((char= char #\e) (format nil "~D" (time-date date))) ;; %H - Hour based on a 24-hour clock as a decimal number [00-23] ((char= char #\H) (format nil "~2,'0D" (time-hour date))) ;; %I - Hour based on a 12-hour clock as a decimal number [01-12] ((char= char #\I) (format nil "~2,'0D" (1+ (mod (time-hour date) 12)))) ;; %m - Month as a decimal number [01-12] ((char= char #\m) (format nil "~2,'0D" (time-month date))) ;; %M - Minute as a decimal number [00-59] ((char= char #\M) (format nil "~2,'0D" (time-minute date))) ;; %S - Second as a decimal number [00-59] ((char= char #\S) (format nil "~2,'0D" (time-second date))) ;; %w - Weekday as a decimal number [0-6], where Sunday is 0 ((char= char #\w) (format nil "~D" (time-day-of-week date))) ;; %y - Year without century [00-99] ((char= char #\y) (let ((year-string (format nil "~,2A" (time-year date)))) (subseq year-string (- (length year-string) 2)))) ;; %Y - Year with century [such as 1990] ((char= char #\Y) (format nil "~D" (time-year date))) (t (error "Ouch - unknown formatter '%~c" char)))) (t char)))))))
lift-standard.config 0 → 100644 +35 −0 Original line number Diff line number Diff line ;;; configuration for LIFT tests ;; settings (:if-dribble-exists :supersede) (:dribble "lift.dribble") (:print-length 10) (:print-level 5) (:print-test-case-names t) ;; suites to run (docudown-test) ;; report properties (:report-property :title "DocuDown | Test results") (:report-property :relative-to docudown-test) (:report-property :style-sheet "test-style.css") (:report-property :if-exists :supersede) (:report-property :format :html) (:report-property :name "test-results/test-report.html") (:report-property :unique-name t) (:build-report) (:report-property :unique-name t) (:report-property :format :describe) (:report-property :name "test-results/test-report.txt") (:build-report) (:report-property :format :save) (:report-property :name "test-results/test-report.sav") (:build-report) (:report-property :format :describe) (:report-property :full-pathname *standard-output*) (:build-report)
test/packages.lisp +1 −1 Original line number Diff line number Diff line (in-package #:common-lisp-user) (defpackage #:trivial-backtrace-test (:use #:common-lisp #:lift)) (:use #:common-lisp #:lift #:trivial-backtrace))