get-backtrace.lisp

   1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
   2 ;;; $Header: /usr/local/cvsrep/hunchentoot/port-cmu.lisp,v 1.12 2008/04/08 14:39:18 edi Exp $
   3
   4 ;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved.
   5
   6 ;;; Redistribution and use in source and binary forms, with or without
   7 ;;; modification, are permitted provided that the following conditions
   8 ;;; are met:
   9
  10 ;;;   * Redistributions of source code must retain the above copyright
  11 ;;;     notice, this list of conditions and the following disclaimer.
  12
  13 ;;;   * Redistributions in binary form must reproduce the above
  14 ;;;     copyright notice, this list of conditions and the following
  15 ;;;     disclaimer in the documentation and/or other materials
  16 ;;;     provided with the distribution.
  17
  18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29
  30 (in-package :hunchentoot)
  31
  32 #+cmu
  33 (defun get-backtrace (error)
  34   "This is the function that is used internally by Hunchentoot to
  35 show or log backtraces.  It accepts a condition object ERROR and
  36 returns a string with the corresponding backtrace."
  37   (declare (ignore error))
  38   (with-output-to-string (s)
  39     (let ((debug:*debug-print-level* nil)
  40           (debug:*debug-print-length* nil))
  41       (debug:backtrace most-positive-fixnum s))))
  42
  43 #+allegro
  44 (defun get-backtrace (error)
  45   "This is the function that is used internally by Hunchentoot to
  46 show or log backtraces.  It accepts a condition object ERROR and
  47 returns a string with the corresponding backtrace."
  48   (with-output-to-string (s)
  49     (with-standard-io-syntax
  50       (let ((*print-readably* nil)
  51             (*print-miser-width* 40)
  52             (*print-pretty* t)
  53             (tpl:*zoom-print-circle* t)
  54             (tpl:*zoom-print-level* nil)
  55             (tpl:*zoom-print-length* nil))
  56         (ignore-errors
  57           (format *terminal-io* "~
  58 ~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
  59                   error))
  60         (ignore-errors
  61           (let ((*terminal-io* s)
  62                 (*standard-output* s))
  63             (tpl:do-command "zoom"
  64                             :from-read-eval-print-loop nil
  65                             :count t
  66                             :all t)))))))
  67
  68 #+openmcl
  69 (defun get-backtrace (error)
  70   "This is the function that is used internally by Hunchentoot to
  71 show or log backtraces.  It accepts a condition object ERROR and
  72 returns a string with the corresponding backtrace."
  73   (with-output-to-string (s)
  74     (let ((*debug-io* s))
  75       (format *terminal-io* "~
  76 ~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
  77               error)
  78       (ccl:print-call-history :detailed-p nil))))
  79
  80 #+clisp
  81 (defun get-backtrace (error)
  82   "This is the function that is used internally by Hunchentoot to
  83 show or log backtraces."
  84   (declare (ignore error))
  85   (with-output-to-string (stream)
  86     (system::print-backtrace :out stream)))
  87
  88 #+lispworks
  89 (defun get-backtrace (error)
  90   "This is the function that is used internally by Hunchentoot to
  91 show or log backtraces.  It accepts a condition object ERROR and
  92 returns a string with the corresponding backtrace."
  93   (declare (ignore error))
  94   (with-output-to-string (s)
  95     (let ((dbg::*debugger-stack* (dbg::grab-stack nil :how-many most-positive-fixnum))
  96           (*debug-io* s)
  97           (dbg:*debug-print-level* nil)
  98           (dbg:*debug-print-length* nil))
  99       (dbg:bug-backtrace nil))))
 100
 101
 102 ;; determine how we're going to access the backtrace in the next
 103 ;; function
 104 #+sbcl
 105 (eval-when (:compile-toplevel :load-toplevel :execute)
 106   (when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug)
 107     (pushnew :hunchentoot-sbcl-debug-print-variable-alist *features*)))
 108
 109 #+sbcl
 110 (defun get-backtrace (error)
 111   "This is the function that is used internally by Hunchentoot to
 112 show or log backtraces.  It accepts a condition object ERROR and
 113 returns a string with the corresponding backtrace."
 114   (declare (ignore error))
 115   (with-output-to-string (s)
 116     #+:hunchentoot-sbcl-debug-print-variable-alist
 117     (let ((sb-debug:*debug-print-variable-alist*
 118             (list* '(*print-level* . nil)
 119                    '(*print-length* . nil)
 120                    sb-debug:*debug-print-variable-alist*)))
 121       (sb-debug:backtrace most-positive-fixnum s))
 122     #-:hunchentoot-sbcl-debug-print-variable-alist
 123     (let ((sb-debug:*debug-print-level* nil)
 124           (sb-debug:*debug-print-length* nil))
 125       (sb-debug:backtrace most-positive-fixnum s))))