3 (setf (documentation 'get-backtrace
'function
)
4 "This is the function that is used internally by Hunchentoot to
5 show or log backtraces. It accepts a condition object ERROR and
6 returns a string with the corresponding backtrace.")
8 (defun ensure-directory (pathname)
9 (merge-pathnames (make-pathname :name
:unspecific
13 (defun writable-directory-p (directory)
14 (let ((directory (ensure-directory directory
)))
15 (and (probe-file directory
)
17 (excl.osi
:access directory excl.osi
:*w-ok
*))))
20 (defun total-bytes-allocated ()
21 (sys::gsgc-totalloc-bytes t
))
23 #+(or digitool openmcl
)
24 (defun total-bytes-allocated ()
25 (ccl::total-bytes-allocated
))
28 (defun total-bytes-allocated ()
29 (cl-user::get-bytes-consed
))
32 (defun get-backtrace (error)
33 (with-output-to-string (s)
35 (format *terminal-io
* "~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
37 (ccl:print-call-history
:detailed-p nil
))))
40 (defun get-backtrace (error)
41 (with-output-to-string (s)
42 (with-standard-io-syntax
43 (let ((*print-readably
* nil
)
44 (*print-miser-width
* 40)
46 (tpl:*zoom-print-circle
* t
)
47 (tpl:*zoom-print-level
* nil
)
48 (tpl:*zoom-print-length
* nil
))
50 (format *terminal-io
* "~&~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
53 (let ((*terminal-io
* s
)
54 (*standard-output
* s
))
55 (tpl:do-command
"zoom"
56 :from-read-eval-print-loop nil
61 (defun zoom-to-stream (condition output
)
62 (with-standard-io-syntax
63 (let ((*print-readably
* nil
)
64 (*print-miser-width
* 40)
66 (tpl:*zoom-print-circle
* t
)
67 (tpl:*zoom-print-level
* nil
)
68 (tpl:*zoom-print-length
* nil
))
70 (format *terminal-io
* "Creating backtrace for ~a to ~a"
74 (let ((*terminal-io
* s
)
75 (*standard-output
* s
))
76 (tpl:do-command
"zoom"
77 :from-read-eval-print-loop nil
79 (cond ((streamp output
)
82 (ensure-directories-exist output
)
83 (with-open-file (s output
:direction
:output
85 :if-does-not-exist
:create
)
89 (defun get-backtrace (error)
90 (declare (ignore error
))
91 (with-output-to-string (s)
92 (let ((dbg::*debugger-stack
* (dbg::grab-stack nil
:how-many most-positive-fixnum
))
94 (dbg:*debug-print-level
* nil
)
95 (dbg:*debug-print-length
* nil
))
96 (dbg:bug-backtrace nil
))))
99 ;; determine how we're going to access the backtrace in the next
101 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
102 (when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug
)
103 (pushnew :hunchentoot-sbcl-debug-print-variable-alist
*features
*)))
106 (defun get-backtrace (error)
107 (declare (ignore error
))
108 (with-output-to-string (s)
109 #+:hunchentoot-sbcl-debug-print-variable-alist
110 (let ((sb-debug:*debug-print-variable-alist
*
111 (list* '(*print-level
* . nil
)
112 '(*print-length
* . nil
)
113 sb-debug
:*debug-print-variable-alist
*)))
114 (sb-debug:backtrace most-positive-fixnum s
))
115 #-
:hunchentoot-sbcl-debug-print-variable-alist
116 (let ((sb-debug:*debug-print-level
* nil
)
117 (sb-debug:*debug-print-length
* nil
))
118 (sb-debug:backtrace most-positive-fixnum s
))))
121 (defun get-backtrace (error)
122 (declare (ignore error
))
123 (with-output-to-string (s)
124 (let ((debug:*debug-print-level
* nil
)
125 (debug:*debug-print-length
* nil
))
126 (debug:backtrace most-positive-fixnum s
))))