Initial checkin

[clg] / glib / gerror.lisp

diff --git a/glib/gerror.lisp b/glib/gerror.lisp
new file mode 100644 (file)
index 0000000..ed2ad71
--- /dev/null
+++ b/glib/gerror.lisp
@@ -0,0 +1,134 @@
+;; Common Lisp bindings for GTK+ v2.0
+;; Copyright (C) 2005 Espen S. Johnsen <espen@users.sf.net>
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+;; $Id: gerror.lisp,v 1.1 2005-02-14 00:39:39 espen Exp $
+
+
+(in-package "GLIB")
+
+(defclass gerror (struct)
+  ((domain :allocation :alien :type quark :reader gerror-domain)
+   (code :allocation :alien :type int :reader gerror-code)
+   (message :allocation :alien :type string :reader gerror-message))
+  (:metaclass struct-class))
+
+(defbinding (%gerror-copy "g_error_copy") () pointer
+  (location pointer))
+
+(defbinding (%gerror-free "g_error_free") () nil
+  (location pointer))
+
+(defmethod reference-foreign ((class (eql (find-class 'gerror))) location)
+  (declare (ignore class))
+  (%gerror-copy location))
+
+(defmethod unreference-foreign ((class (eql (find-class 'gerror))) location)
+  (declare (ignore class))
+  (%gerror-free location))
+
+
+(define-condition glib-error (error)
+  ((code :initarg :domain :reader gerror-code)
+   (message :initarg :message :reader gerror-message))
+  (:report (lambda (condition stream)
+            (write-string (gerror-message condition) stream))))
+
+(define-condition glib-file-error (glib-error)
+  ())
+
+(defbinding file-error-quark () quark)
+
+(defun signal-gerror (gerror)
+  (let ((condition
+        (cond
+         ((= (gerror-domain gerror) (file-error-quark)) 'glib-file-error)
+         (t 'glib-error))))
+    (error condition :code (gerror-code gerror) :message (gerror-message gerror))))
+
+
+;;; Message logging
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (deftype log-levels () 
+    '(flags 
+      :recursion :fatal ;; These are not real log-levels, but flags
+                       ;; which may be set
+      error-log-level
+      critical-log-level
+      warning-log-level
+      message-log-level
+      info-log-level
+      debug-log-level)))
+
+(define-condition log-level (warning)
+  ((domain :initarg :domain :reader log-domain)
+   (message :initarg :message :reader log-message))
+  (:report (lambda (condition stream)
+            (format stream "~A: ~A" 
+             (log-domain condition) (log-message condition)))))
+
+(define-condition unknown-log-level (log-level)
+  ())
+
+(define-condition error-log-level (log-level)
+  ())
+
+(define-condition critical-log-level (log-level)
+  ())
+
+(define-condition warning-log-level (log-level)
+  ())
+
+(define-condition info-log-level (log-level)
+  ())
+
+(define-condition debug-log-level (log-level)
+  ())
+
+(defparameter *fatal-log-levels* '(error-log-level critical-log-level))
+
+(defcallback log-handler (nil 
+                          (domain (copy-of string))
+                          (log-level log-levels)
+                          (message (copy-of string)))
+  (let ((fatal-p (or
+                 (find :fatal log-level)
+                 (some 
+                  #'(lambda (level) (find level *fatal-log-levels*))
+                  log-level)))
+       (condition (or
+                   (find-if 
+                    #'(lambda (level) (subtypep level 'condition))
+                    log-level)
+                   'unknown-log-level)))
+    (funcall (if fatal-p #'error #'warn) condition
+     :domain domain :message message)))
+
+(setf (extern-alien "log_handler" system-area-pointer) (callback log-handler))
+
+
+#+glib2.6
+(progn
+  ;; Unfortunately this will only work as long as we don't abort to
+  ;; toplevel from within the log handler. If we do that, the next
+  ;; invocation of g_log will be handled as a recursion and cause an
+  ;; abort (SIGABORT being signaled). To make things even worse, SBCL
+  ;; doesn't handle SIGABRT at all.
+  (defbinding %log-set-default-handler () pointer
+    ((callback log-handler) pointer)
+    (nil null))
+  (%log-set-default-handler))