chiark / gitweb /
Code to set gerrors from callbacks
[clg] / glib / gerror.lisp
CommitLineData
65f5a6e1 1;; Common Lisp bindings for GTK+ v2.0
31ce821b 2;; Copyright 2005-2006 Espen S. Johnsen <espen@users.sf.net>
65f5a6e1 3;;
112ac1d3 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:
65f5a6e1 11;;
112ac1d3 12;; The above copyright notice and this permission notice shall be
13;; included in all copies or substantial portions of the Software.
65f5a6e1 14;;
112ac1d3 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.
65f5a6e1 22
dd70f526 23;; $Id: gerror.lisp,v 1.11 2008-12-10 02:49:17 espen Exp $
65f5a6e1 24
25
26(in-package "GLIB")
27
dd70f526 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)))
65f5a6e1 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
dd70f526 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
65f5a6e1 61(define-condition glib-error (error)
f595e05c 62 ((code :initarg :code :reader gerror-code)
65f5a6e1 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
dd70f526 70(defbinding (file-error-domain "g_file_error_quark") () quark)
65f5a6e1 71
72(defun signal-gerror (gerror)
73 (let ((condition
74 (cond
dd70f526 75 ((= (gerror-domain gerror) (file-error-domain)) 'glib-file-error)
65f5a6e1 76 (t 'glib-error))))
77 (error condition :code (gerror-code gerror) :message (gerror-message gerror))))
78
dd70f526 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
65f5a6e1 91
b4a94e20 92(deftype gerror-signal () 'gerror)
93
82f3b33c 94(define-type-method return-type ((type gerror-signal))
95 (declare (ignore type))
96 '(or null gerror))
97
31ce821b 98(define-type-method from-alien-form ((type gerror-signal) gerror &key (ref :free))
75689fea 99 (declare (ignore type))
31ce821b 100 `(let ((gerror ,(from-alien-form 'gerror gerror :ref ref)))
b4a94e20 101 (when gerror
102 (signal-gerror gerror))))
103
104
65f5a6e1 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
43656337 138(define-condition message-log-level (log-level)
139 ())
140
65f5a6e1 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
56ccd5b7 149(define-callback log-handler nil
150 ((domain string) (log-level log-levels) (message string))
65f5a6e1 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
31ce821b 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)
56ccd5b7 168 (callback-address log-handler))
65f5a6e1 169
170
31ce821b 171#?(pkg-exists-p "glib-2.0" :atleast-version "2.6.0")
65f5a6e1 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.
31ce821b 178 (defbinding %log-set-default-handler (nil) pointer
179 (log-handler callback)
65f5a6e1 180 (nil null))
181 (%log-set-default-handler))