chiark / gitweb /
Type method system redesigned
[clg] / 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.5 2006-02-26 15:30:01 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 (deftype gerror-signal () 'gerror)
69
70 (define-type-method from-alien-form ((type gerror-signal) gerror)
71   (declare (ignore type))
72   `(let ((gerror ,(from-alien-form 'gerror gerror)))
73      (when gerror
74        (signal-gerror gerror))))
75
76  
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
118 (define-callback log-handler nil 
119     ((domain string) (log-level log-levels) (message string))
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
133 (setf (extern-alien "log_handler" system-area-pointer) 
134  (callback-address log-handler))
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
145     ((progn log-handler) callback)
146     (nil null))
147   (%log-set-default-handler))