chiark / gitweb /
Defgeneric added to get rid of a style warning
[clg] / glib / gerror.lisp
CommitLineData
65f5a6e1 1;; Common Lisp bindings for GTK+ v2.0
112ac1d3 2;; Copyright 2005 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
75689fea 23;; $Id: gerror.lisp,v 1.5 2006-02-26 15:30:01 espen Exp $
65f5a6e1 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
b4a94e20 68(deftype gerror-signal () 'gerror)
69
75689fea 70(define-type-method from-alien-form ((type gerror-signal) gerror)
71 (declare (ignore type))
72 `(let ((gerror ,(from-alien-form 'gerror gerror)))
b4a94e20 73 (when gerror
74 (signal-gerror gerror))))
75
76
65f5a6e1 77;;; Message logging
78
79(eval-when (:compile-toplevel :load-toplevel :execute)
80 (deftype log-levels ()
81 '(flags
82 :recursion :fatal ;; These are not real log-levels, but flags
83 ;; which may be set
84 error-log-level
85 critical-log-level
86 warning-log-level
87 message-log-level
88 info-log-level
89 debug-log-level)))
90
91(define-condition log-level (warning)
92 ((domain :initarg :domain :reader log-domain)
93 (message :initarg :message :reader log-message))
94 (:report (lambda (condition stream)
95 (format stream "~A: ~A"
96 (log-domain condition) (log-message condition)))))
97
98(define-condition unknown-log-level (log-level)
99 ())
100
101(define-condition error-log-level (log-level)
102 ())
103
104(define-condition critical-log-level (log-level)
105 ())
106
107(define-condition warning-log-level (log-level)
108 ())
109
110(define-condition info-log-level (log-level)
111 ())
112
113(define-condition debug-log-level (log-level)
114 ())
115
116(defparameter *fatal-log-levels* '(error-log-level critical-log-level))
117
56ccd5b7 118(define-callback log-handler nil
119 ((domain string) (log-level log-levels) (message string))
65f5a6e1 120 (let ((fatal-p (or
121 (find :fatal log-level)
122 (some
123 #'(lambda (level) (find level *fatal-log-levels*))
124 log-level)))
125 (condition (or
126 (find-if
127 #'(lambda (level) (subtypep level 'condition))
128 log-level)
129 'unknown-log-level)))
130 (funcall (if fatal-p #'error #'warn) condition
131 :domain domain :message message)))
132
56ccd5b7 133(setf (extern-alien "log_handler" system-area-pointer)
134 (callback-address log-handler))
65f5a6e1 135
136
137#+glib2.6
138(progn
139 ;; Unfortunately this will only work as long as we don't abort to
140 ;; toplevel from within the log handler. If we do that, the next
141 ;; invocation of g_log will be handled as a recursion and cause an
142 ;; abort (SIGABORT being signaled). To make things even worse, SBCL
143 ;; doesn't handle SIGABRT at all.
144 (defbinding %log-set-default-handler () pointer
56ccd5b7 145 ((progn log-handler) callback)
65f5a6e1 146 (nil null))
147 (%log-set-default-handler))