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

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 2005 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; This library is free software; you can redistribute it and/or
   5 ;; modify it under the terms of the GNU Lesser General Public
   6 ;; License as published by the Free Software Foundation; either
   7 ;; version 2 of the License, or (at your option) any later version.
   8 ;;
   9 ;; This library is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;; Lesser General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU Lesser General Public
  15 ;; License along with this library; if not, write to the Free Software
  16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18 ;; $Id: gerror.lisp,v 1.1 2005-02-14 00:39:39 espen Exp $
  19
  20
  21 (in-package "GLIB")
  22
  23 (defclass gerror (struct)
  24   ((domain :allocation :alien :type quark :reader gerror-domain)
  25    (code :allocation :alien :type int :reader gerror-code)
  26    (message :allocation :alien :type string :reader gerror-message))
  27   (:metaclass struct-class))
  28
  29 (defbinding (%gerror-copy "g_error_copy") () pointer
  30   (location pointer))
  31
  32 (defbinding (%gerror-free "g_error_free") () nil
  33   (location pointer))
  34
  35 (defmethod reference-foreign ((class (eql (find-class 'gerror))) location)
  36   (declare (ignore class))
  37   (%gerror-copy location))
  38
  39 (defmethod unreference-foreign ((class (eql (find-class 'gerror))) location)
  40   (declare (ignore class))
  41   (%gerror-free location))
  42
  43
  44 (define-condition glib-error (error)
  45   ((code :initarg :domain :reader gerror-code)
  46    (message :initarg :message :reader gerror-message))
  47   (:report (lambda (condition stream)
  48              (write-string (gerror-message condition) stream))))
  49
  50 (define-condition glib-file-error (glib-error)
  51   ())
  52
  53 (defbinding file-error-quark () quark)
  54
  55 (defun signal-gerror (gerror)
  56   (let ((condition
  57          (cond
  58           ((= (gerror-domain gerror) (file-error-quark)) 'glib-file-error)
  59           (t 'glib-error))))
  60     (error condition :code (gerror-code gerror) :message (gerror-message gerror))))
  61
  62
  63 ;;; Message logging
  64
  65 (eval-when (:compile-toplevel :load-toplevel :execute)
  66   (deftype log-levels ()
  67     '(flags
  68       :recursion :fatal ;; These are not real log-levels, but flags
  69                         ;; which may be set
  70       error-log-level
  71       critical-log-level
  72       warning-log-level
  73       message-log-level
  74       info-log-level
  75       debug-log-level)))
  76
  77 (define-condition log-level (warning)
  78   ((domain :initarg :domain :reader log-domain)
  79    (message :initarg :message :reader log-message))
  80   (:report (lambda (condition stream)
  81              (format stream "~A: ~A"
  82               (log-domain condition) (log-message condition)))))
  83
  84 (define-condition unknown-log-level (log-level)
  85   ())
  86
  87 (define-condition error-log-level (log-level)
  88   ())
  89
  90 (define-condition critical-log-level (log-level)
  91   ())
  92
  93 (define-condition warning-log-level (log-level)
  94   ())
  95
  96 (define-condition info-log-level (log-level)
  97   ())
  98
  99 (define-condition debug-log-level (log-level)
 100   ())
 101
 102 (defparameter *fatal-log-levels* '(error-log-level critical-log-level))
 103
 104 (defcallback log-handler (nil
 105                            (domain (copy-of string))
 106                            (log-level log-levels)
 107                            (message (copy-of string)))
 108   (let ((fatal-p (or
 109                   (find :fatal log-level)
 110                   (some
 111                    #'(lambda (level) (find level *fatal-log-levels*))
 112                    log-level)))
 113         (condition (or
 114                     (find-if
 115                      #'(lambda (level) (subtypep level 'condition))
 116                      log-level)
 117                     'unknown-log-level)))
 118     (funcall (if fatal-p #'error #'warn) condition
 119      :domain domain :message message)))
 120
 121 (setf (extern-alien "log_handler" system-area-pointer) (callback log-handler))
 122
 123
 124 #+glib2.6
 125 (progn
 126   ;; Unfortunately this will only work as long as we don't abort to
 127   ;; toplevel from within the log handler. If we do that, the next
 128   ;; invocation of g_log will be handled as a recursion and cause an
 129   ;; abort (SIGABORT being signaled). To make things even worse, SBCL
 130   ;; doesn't handle SIGABRT at all.
 131   (defbinding %log-set-default-handler () pointer
 132     ((callback log-handler) pointer)
 133     (nil null))
 134   (%log-set-default-handler))