conditions.lisp

   1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
   2
   3 ;;; Copyright (c) 2008-2009, Dr. Edmund Weitz.  All rights reserved.
   4
   5 ;;; Redistribution and use in source and binary forms, with or without
   6 ;;; modification, are permitted provided that the following conditions
   7 ;;; are met:
   8
   9 ;;;   * Redistributions of source code must retain the above copyright
  10 ;;;     notice, this list of conditions and the following disclaimer.
  11
  12 ;;;   * Redistributions in binary form must reproduce the above
  13 ;;;     copyright notice, this list of conditions and the following
  14 ;;;     disclaimer in the documentation and/or other materials
  15 ;;;     provided with the distribution.
  16
  17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  20 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  28
  29 (in-package :hunchentoot)
  30
  31 (define-condition hunchentoot-condition (condition)
  32   ()
  33   (:documentation "Superclass for all conditions related to Hunchentoot."))
  34
  35 (define-condition detach-socket (hunchentoot-condition)
  36   ()
  37   (:documentation "When this condition is signalled,
  38   PROCESS-CONNECTION detaches from the connection socket after
  39   processing the current request, leaving it up to other software to
  40   deal with."))
  41
  42 (define-condition hunchentoot-error (hunchentoot-condition error)
  43   ()
  44   (:documentation "Superclass for all errors related to Hunchentoot."))
  45
  46 (define-condition hunchentoot-simple-error (hunchentoot-error simple-condition)
  47   ()
  48   (:documentation "Like HUNCHENTOOT-ERROR but with formatting capabilities."))
  49
  50 (defun hunchentoot-error (format-control &rest format-arguments)
  51   "Signals an error of type HUNCHENTOOT-SIMPLE-ERROR with the provided
  52 format control and arguments."
  53   (error 'hunchentoot-simple-error
  54          :format-control format-control
  55          :format-arguments format-arguments))
  56
  57 (define-condition hunchentoot-warning (hunchentoot-condition warning)
  58   ()
  59   (:documentation "Superclass for all warnings related to Hunchentoot."))
  60
  61 (define-condition hunchentoot-simple-warning (hunchentoot-warning simple-condition)
  62   ()
  63   (:documentation "Like HUNCHENTOOT-WARNING but with formatting capabilities."))
  64
  65 (defun hunchentoot-warn (format-control &rest format-arguments)
  66   "Signals a warning of type HUNCHENTOOT-SIMPLE-WARNING with the
  67 provided format control and arguments."
  68   (warn 'hunchentoot-simple-warning
  69         :format-control format-control
  70         :format-arguments format-arguments))
  71
  72 (define-condition parameter-error (hunchentoot-simple-error)
  73   ()
  74   (:documentation "Signalled if a function was called with incosistent or illegal parameters."))
  75
  76 (defun parameter-error (format-control &rest format-arguments)
  77   "Signals an error of type PARAMETER-ERROR with the provided
  78 format control and arguments."
  79   (error 'parameter-error
  80          :format-control format-control
  81          :format-arguments format-arguments))
  82
  83 (define-condition operation-not-implemented (hunchentoot-error)
  84   ((operation :initarg :operation
  85               :reader hunchentoot-operation-not-implemented-operation
  86               :documentation "The name of the unimplemented operation."))
  87   (:report (lambda (condition stream)
  88              (format stream "The operation ~A is not yet implemented for the implementation ~A.
  89 Consider sending a patch..."
  90                      (hunchentoot-operation-not-implemented-operation condition)
  91                      (lisp-implementation-type))))
  92   (:documentation "This warning is signalled when an operation \(like
  93 SETUID for example) is not implemented for a specific Lisp."))
  94
  95 (defun not-implemented (name)
  96   "Used to signal an error if an operation named NAME is not implemented."
  97   (error 'operation-not-implemented :operation name))
  98
  99 (defgeneric maybe-invoke-debugger (condition)
 100   (:documentation "This generic function is called whenever a
 101 condition CONDITION is signaled in Hunchentoot.  You might want to
 102 specialize it on specific condition classes for debugging purposes.")
 103   (:method (condition)
 104    "The default method invokes the debugger with CONDITION if
 105 *CATCH-ERRORS-P* is NIL."
 106    (unless *catch-errors-p*
 107      (invoke-debugger condition))))
 108
 109 (defmacro with-debugger (&body body)
 110   "Executes BODY and invokes the debugger if an error is signaled and
 111 *CATCH-ERRORS-P* is NIL."
 112   `(handler-bind ((error #'maybe-invoke-debugger))
 113      ,@body))
 114
 115 (defmacro ignore-errors* (&body body)
 116   "Like IGNORE-ERRORS, but observes *CATCH-ERRORS-P*."
 117   `(ignore-errors (with-debugger ,@body)))
 118
 119 (defmacro handler-case* (expression &rest clauses)
 120   "Like HANDLER-CASE, but observes *CATCH-ERRORS-P*."
 121   `(handler-case (with-debugger ,expression)
 122      ,@clauses))
 123
 124 (defun get-backtrace ()
 125   "Returns a string with a backtrace of what the Lisp system thinks is
 126 the \"current\" error."
 127   (handler-case
 128       (with-output-to-string (s)
 129         (trivial-backtrace:print-backtrace-to-stream s))
 130     (error (condition)
 131       (format nil "Could not generate backtrace: ~A." condition))))