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
*))))
19 ;; Handle missing platforms gracefully?
20 (defun total-bytes-allocated ()
21 (if (fboundp '%total-bytes-allocated
)
22 (funcall '%total-bytes-allocated
)
26 (defun %total-bytes-allocated
()
27 (sys::gsgc-totalloc-bytes t
))
29 #+(or digitool openmcl
)
30 (defun %total-bytes-allocated
()
31 (ccl::total-bytes-allocated
))
34 (defun %total-bytes-allocated
()
35 (cl-user::get-bytes-consed
))
38 (defun %total-bytes-allocated
()
39 (ext:get-bytes-consed
))
42 ;; thanks to Frank Schorr, via e-mail
43 (defun %total-bytes-allocated
()
44 (hcl:total-allocation
))
47 (defun get-backtrace (error)
48 (with-output-to-string (s)
50 (format *terminal-io
* "~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
52 (ccl:print-call-history
:detailed-p nil
))))
55 (defun get-backtrace (error)
56 (with-output-to-string (s)
57 (with-standard-io-syntax
58 (let ((*print-readably
* nil
)
59 (*print-miser-width
* 40)
61 (tpl:*zoom-print-circle
* t
)
62 (tpl:*zoom-print-level
* nil
)
63 (tpl:*zoom-print-length
* nil
))
65 (format *terminal-io
* "~&~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
68 (let ((*terminal-io
* s
)
69 (*standard-output
* s
))
70 (tpl:do-command
"zoom"
71 :from-read-eval-print-loop nil
76 (defun zoom-to-stream (condition output
)
77 (with-standard-io-syntax
78 (let ((*print-readably
* nil
)
79 (*print-miser-width
* 40)
81 (tpl:*zoom-print-circle
* t
)
82 (tpl:*zoom-print-level
* nil
)
83 (tpl:*zoom-print-length
* nil
))
85 (format *terminal-io
* "Creating backtrace for ~a to ~a"
89 (let ((*terminal-io
* s
)
90 (*standard-output
* s
))
91 (tpl:do-command
"zoom"
92 :from-read-eval-print-loop nil
94 (cond ((streamp output
)
97 (ensure-directories-exist output
)
98 (with-open-file (s output
:direction
:output
100 :if-does-not-exist
:create
)
104 (defun get-backtrace (error)
105 (declare (ignore error
))
106 (with-output-to-string (s)
107 (let ((dbg::*debugger-stack
* (dbg::grab-stack nil
:how-many most-positive-fixnum
))
109 (dbg:*debug-print-level
* nil
)
110 (dbg:*debug-print-length
* nil
))
111 (dbg:bug-backtrace nil
))))
114 ;; determine how we're going to access the backtrace in the next
116 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
117 (when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug
)
118 (pushnew :hunchentoot-sbcl-debug-print-variable-alist
*features
*)))
121 (defun get-backtrace (error)
122 (declare (ignore error
))
123 (with-output-to-string (s)
124 #+:hunchentoot-sbcl-debug-print-variable-alist
125 (let ((sb-debug:*debug-print-variable-alist
*
126 (list* '(*print-level
* . nil
)
127 '(*print-length
* . nil
)
128 sb-debug
:*debug-print-variable-alist
*)))
129 (sb-debug:backtrace most-positive-fixnum s
))
130 #-
:hunchentoot-sbcl-debug-print-variable-alist
131 (let ((sb-debug:*debug-print-level
* nil
)
132 (sb-debug:*debug-print-length
* nil
))
133 (sb-debug:backtrace most-positive-fixnum s
))))
136 (defun get-backtrace (error)
137 (declare (ignore error
))
138 (with-output-to-string (s)
139 (system::print-backtrace
:out s
)))
142 (defun get-backtrace (error)
143 (declare (ignore error
))
144 (with-output-to-string (s)
145 (let ((debug:*debug-print-level
* nil
)
146 (debug:*debug-print-length
* nil
))
147 (debug:backtrace most-positive-fixnum s
))))
149 (define-condition timeout-error
(error)
151 (:report
(lambda (c s
)
153 (format s
"Process timeout"))))
155 (defmacro with-timeout
((seconds) &body body
)
156 (let ((gseconds (gensym)))
157 `(let ((,gseconds
,seconds
))
162 (mp:with-timeout
(,gseconds
(error 'timeout-error
))
165 (mp:with-timeout
(,gseconds
) (doit))
168 (sb-ext:with-timeout
,gseconds
(doit))
170 (cerror "Timeout" 'timeout-error
)))
171 #+(or digitool openmcl
)
172 (let ((checker-process (format nil
"Checker ~S" (gensym)))
173 (waiting-process (format nil
"Waiter ~S" (gensym)))
177 (,process
(ccl:process-run-function
180 (setf ,result
(progn (doit)))))))
181 (ccl:process-wait-with-timeout
183 (* ,gseconds
#+openmcl ccl
:*ticks-per-second
* #+digitool
60)
185 (not (ccl::process-active-p
,process
))))
186 (when (ccl::process-active-p
,process
)
187 (ccl:process-kill
,process
)
188 (cerror "Timeout" 'timeout-error
))
190 #-
(or allegro cmu sb-thread openmcl digitool
)