chiark - git - mdw - clg/blob - glib/gerror.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright 2005 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: gerror.lisp,v 1.2 2005-04-23 16:48:50 espen Exp $
  24
  25
  26 (in-package "GLIB")
  27
  28 (defclass gerror (struct)
  29   ((domain :allocation :alien :type quark :reader gerror-domain)
  30    (code :allocation :alien :type int :reader gerror-code)
  31    (message :allocation :alien :type string :reader gerror-message))
  32   (:metaclass struct-class))
  33
  34 (defbinding (%gerror-copy "g_error_copy") () pointer
  35   (location pointer))
  36
  37 (defbinding (%gerror-free "g_error_free") () nil
  38   (location pointer))
  39
  40 (defmethod reference-foreign ((class (eql (find-class 'gerror))) location)
  41   (declare (ignore class))
  42   (%gerror-copy location))
  43
  44 (defmethod unreference-foreign ((class (eql (find-class 'gerror))) location)
  45   (declare (ignore class))
  46   (%gerror-free location))
  47
  48
  49 (define-condition glib-error (error)
  50   ((code :initarg :domain :reader gerror-code)
  51    (message :initarg :message :reader gerror-message))
  52   (:report (lambda (condition stream)
  53              (write-string (gerror-message condition) stream))))
  54
  55 (define-condition glib-file-error (glib-error)
  56   ())
  57
  58 (defbinding file-error-quark () quark)
  59
  60 (defun signal-gerror (gerror)
  61   (let ((condition
  62          (cond
  63           ((= (gerror-domain gerror) (file-error-quark)) 'glib-file-error)
  64           (t 'glib-error))))
  65     (error condition :code (gerror-code gerror) :message (gerror-message gerror))))
  66
  67
  68 ;;; Message logging
  69
  70 (eval-when (:compile-toplevel :load-toplevel :execute)
  71   (deftype log-levels ()
  72     '(flags
  73       :recursion :fatal ;; These are not real log-levels, but flags
  74                         ;; which may be set
  75       error-log-level
  76       critical-log-level
  77       warning-log-level
  78       message-log-level
  79       info-log-level
  80       debug-log-level)))
  81
  82 (define-condition log-level (warning)
  83   ((domain :initarg :domain :reader log-domain)
  84    (message :initarg :message :reader log-message))
  85   (:report (lambda (condition stream)
  86              (format stream "~A: ~A"
  87               (log-domain condition) (log-message condition)))))
  88
  89 (define-condition unknown-log-level (log-level)
  90   ())
  91
  92 (define-condition error-log-level (log-level)
  93   ())
  94
  95 (define-condition critical-log-level (log-level)
  96   ())
  97
  98 (define-condition warning-log-level (log-level)
  99   ())
 100
 101 (define-condition info-log-level (log-level)
 102   ())
 103
 104 (define-condition debug-log-level (log-level)
 105   ())
 106
 107 (defparameter *fatal-log-levels* '(error-log-level critical-log-level))
 108
 109 (defcallback log-handler (nil
 110                            (domain (copy-of string))
 111                            (log-level log-levels)
 112                            (message (copy-of string)))
 113   (let ((fatal-p (or
 114                   (find :fatal log-level)
 115                   (some
 116                    #'(lambda (level) (find level *fatal-log-levels*))
 117                    log-level)))
 118         (condition (or
 119                     (find-if
 120                      #'(lambda (level) (subtypep level 'condition))
 121                      log-level)
 122                     'unknown-log-level)))
 123     (funcall (if fatal-p #'error #'warn) condition
 124      :domain domain :message message)))
 125
 126 (setf (extern-alien "log_handler" system-area-pointer) (callback log-handler))
 127
 128
 129 #+glib2.6
 130 (progn
 131   ;; Unfortunately this will only work as long as we don't abort to
 132   ;; toplevel from within the log handler. If we do that, the next
 133   ;; invocation of g_log will be handled as a recursion and cause an
 134   ;; abort (SIGABORT being signaled). To make things even worse, SBCL
 135   ;; doesn't handle SIGABRT at all.
 136   (defbinding %log-set-default-handler () pointer
 137     ((callback log-handler) pointer)
 138     (nil null))
 139   (%log-set-default-handler))