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

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright 2005-2006 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.11 2008-12-10 02:49:17 espen Exp $
  24
  25
  26 (in-package "GLIB")
  27
  28 (define-enum-type file-error-enum
  29   :exist :isdir :acces :name-too-long :noent :notdir :nxio :nodev :rofs :txtbsy
  30   :fault :loop :nospc :nomem :mfile :nfile :badf :inval :pipe :again :intr
  31   :io :perm :nosys :failed)
  32
  33 (eval-when (:compile-toplevel :load-toplevel :execute)
  34   (defclass gerror (struct)
  35     ((domain :allocation :alien :type quark :reader gerror-domain)
  36      (code :allocation :alien :type int :reader gerror-code)
  37      (message :allocation :alien :type string :reader gerror-message))
  38     (:metaclass struct-class)
  39     (:ref %gerror-copy)
  40     (:unref %gerror-free)))
  41
  42 (defbinding (%gerror-copy "g_error_copy") () pointer
  43   (location pointer))
  44
  45 (defbinding (%gerror-free "g_error_free") () nil
  46   (location pointer))
  47
  48 (defbinding (gerror-new "g_error_new_literal")
  49     (domain code format &rest args) gerror
  50   (domain quark)
  51   (code int)
  52   ((apply #'format nil format args) string))
  53
  54 (defbinding (gerror-set "g_set_error_literal")
  55     (gerror domain code format &rest args) nil
  56   gerror
  57   (domain quark)
  58   (code int)
  59   ((apply #'format nil format args) string))
  60
  61 (define-condition glib-error (error)
  62   ((code :initarg :code :reader gerror-code)
  63    (message :initarg :message :reader gerror-message))
  64   (:report (lambda (condition stream)
  65              (write-string (gerror-message condition) stream))))
  66
  67 (define-condition glib-file-error (glib-error)
  68   ())
  69
  70 (defbinding (file-error-domain "g_file_error_quark") () quark)
  71
  72 (defun signal-gerror (gerror)
  73   (let ((condition
  74          (cond
  75           ((= (gerror-domain gerror) (file-error-domain)) 'glib-file-error)
  76           (t 'glib-error))))
  77     (error condition :code (gerror-code gerror) :message (gerror-message gerror))))
  78
  79 ;; This temporary hack is necessary until define-callback gets support
  80 ;; for :in/out parameters
  81 (defun gerror-set-in-callback (indirect-location domain code format &rest args)
  82   (unless (null-pointer-p indirect-location)
  83     (if (null-pointer-p (ref-pointer indirect-location))
  84         (setf (ref-pointer indirect-location)
  85          (funcall (to-alien-function 'gerror)
  86           (apply #'gerror-new domain code format args)))
  87       (let ((gerror (funcall (from-alien-function '(static gerror))
  88                      (ref-pointer indirect-location))))
  89         (apply #'gerror-set gerror domain code format args)))))
  90
  91
  92 (deftype gerror-signal () 'gerror)
  93
  94 (define-type-method return-type ((type gerror-signal))
  95   (declare (ignore type))
  96   '(or null gerror))
  97
  98 (define-type-method from-alien-form ((type gerror-signal) gerror &key (ref :free))
  99   (declare (ignore type))
 100   `(let ((gerror ,(from-alien-form 'gerror gerror :ref ref)))
 101      (when gerror
 102        (signal-gerror gerror))))
 103
 104
 105 ;;; Message logging
 106
 107 (eval-when (:compile-toplevel :load-toplevel :execute)
 108   (deftype log-levels ()
 109     '(flags
 110       :recursion :fatal ;; These are not real log-levels, but flags
 111                         ;; which may be set
 112       error-log-level
 113       critical-log-level
 114       warning-log-level
 115       message-log-level
 116       info-log-level
 117       debug-log-level)))
 118
 119 (define-condition log-level (warning)
 120   ((domain :initarg :domain :reader log-domain)
 121    (message :initarg :message :reader log-message))
 122   (:report (lambda (condition stream)
 123              (format stream "~A: ~A"
 124               (log-domain condition) (log-message condition)))))
 125
 126 (define-condition unknown-log-level (log-level)
 127   ())
 128
 129 (define-condition error-log-level (log-level)
 130   ())
 131
 132 (define-condition critical-log-level (log-level)
 133   ())
 134
 135 (define-condition warning-log-level (log-level)
 136   ())
 137
 138 (define-condition message-log-level (log-level)
 139   ())
 140
 141 (define-condition info-log-level (log-level)
 142   ())
 143
 144 (define-condition debug-log-level (log-level)
 145   ())
 146
 147 (defparameter *fatal-log-levels* '(error-log-level critical-log-level))
 148
 149 (define-callback log-handler nil
 150     ((domain string) (log-level log-levels) (message string))
 151   (let ((fatal-p (or
 152                   (find :fatal log-level)
 153                   (some
 154                    #'(lambda (level) (find level *fatal-log-levels*))
 155                    log-level)))
 156         (condition (or
 157                     (find-if
 158                      #'(lambda (level) (subtypep level 'condition))
 159                      log-level)
 160                     'unknown-log-level)))
 161     (funcall (if fatal-p #'error #'warn) condition
 162      :domain domain :message message)))
 163
 164 #-clisp
 165 (setf
 166  #+cmu(alien:extern-alien "log_handler" alien:system-area-pointer)
 167  #+sbcl(sb-alien:extern-alien "log_handler" sb-alien:system-area-pointer)
 168  (callback-address log-handler))
 169
 170
 171 #?(pkg-exists-p "glib-2.0" :atleast-version "2.6.0")
 172 (progn
 173   ;; Unfortunately this will only work as long as we don't abort to
 174   ;; toplevel from within the log handler. If we do that, the next
 175   ;; invocation of g_log will be handled as a recursion and cause an
 176   ;; abort (SIGABORT being signaled). To make things even worse, SBCL
 177   ;; doesn't handle SIGABRT at all.
 178   (defbinding %log-set-default-handler (nil) pointer
 179     (log-handler callback)
 180     (nil null))
 181   (%log-set-default-handler))