From c4533cf5f9f62b359921a6258d4960c7ab3f6b8e Mon Sep 17 00:00:00 2001
From: Dmitry Kalyanov <Kalyanov.Dmitry@gmail.com>
Date: Tue, 13 Oct 2009 00:30:27 +0400
Subject: [PATCH] Basic GError binding

---
 glib/cl-gtk2-glib.asd |    1 +
 glib/glib.gerror.lisp |   77 +++++++++++++++++++++++++++++++++++++++++++++++++
 glib/glib.lisp        |    8 ++++-
 3 files changed, 85 insertions(+), 1 deletion(-)
 create mode 100644 glib/glib.gerror.lisp

diff --git a/glib/cl-gtk2-glib.asd b/glib/cl-gtk2-glib.asd
index 0007491..9132635 100644
--- a/glib/cl-gtk2-glib.asd
+++ b/glib/cl-gtk2-glib.asd
@@ -8,6 +8,7 @@
                (:file "glib.gstrv")
                (:file "glib.string")
                (:file "glib.quark")
+               (:file "glib.gerror")
 
                (:file "gobject.init")
                (:file "gobject.ffi.package")
diff --git a/glib/glib.gerror.lisp b/glib/glib.gerror.lisp
new file mode 100644
index 0000000..65019c0
--- /dev/null
+++ b/glib/glib.gerror.lisp
@@ -0,0 +1,77 @@
+(in-package :glib)
+
+(defcstruct g-error
+  (:domain g-quark)
+  (:code :int)
+  (:message (:string :free-from-foreign nil)))
+
+(defcfun g-error-new-literal :pointer
+  (domain g-quark)
+  (code :int)
+  (message :string))
+
+(defcfun g-error-free :void
+  (error :pointer))
+
+(defcfun g-error-copy :pointer
+  (error :pointer))
+
+(defcfun g-error-matches :boolean
+  (error :pointer)
+  (domain g-quark)
+  (code :int))
+
+(defcfun g-set-error-literal :void
+  (err-ptr :pointer)
+  (domain g-quark)
+  (code :int)
+  (message :string))
+
+(defcfun g-propagate-error :void
+  (dest-ptr :pointer)
+  (src-ptr :pointer))
+
+(defcfun g-clear-error :void
+  (err-ptr :pointer))
+
+(define-condition g-error-condition (error)
+  ((domain :initarg :domain :initform nil :reader g-error-condition-domain)
+   (code :initarg :code :initform nil :reader g-error-condition-code)
+   (message :initarg :message :initform nil :reader g-error-condition-message))
+  (:report (lambda (e stream)
+             (format stream "GError was raised. Domain: ~S, code: ~S, message: ~A"
+                     (g-error-condition-domain e)
+                     (g-error-condition-code e)
+                     (g-error-condition-message e)))))
+
+(defun mayber-raise-g-error-condition (err)
+  (unless (null-pointer-p err)
+    (error 'g-error-condition
+           :domain (foreign-slot-value err 'g-error :domain)
+           :code (foreign-slot-value err 'g-error :code)
+           :message (foreign-slot-value err 'g-error :message))))
+
+(defmacro with-g-error ((err) &body body)
+  `(with-foreign-object (,err :pointer)
+     (setf (mem-ref ,err :pointer) (null-pointer))
+     (unwind-protect
+          (progn ,@body)
+       (mayber-raise-g-error-condition (mem-ref ,err :pointer))
+       (g-clear-error ,err))))
+
+(defmacro with-catching-to-g-error ((err) &body body)
+  `(handler-case
+       (progn ,@body)
+     (g-error-condition (e)
+       (g-set-error-literal ,err
+                            (g-error-condition-domain e)
+                            (g-error-condition-code e)
+                            (g-error-condition-message e)))))
+
+;; void                g_prefix_error                      (GError **err,
+;;                                                          const gchar *format,
+;;                                                          ...);
+;; void                g_propagate_prefixed_error          (GError **dest,
+;;                                                          GError *src,
+;;                                                          const gchar *format,
+;;                                                          ...);
\ No newline at end of file
diff --git a/glib/glib.lisp b/glib/glib.lisp
index 13f3dfe..9fa7dcb 100755
--- a/glib/glib.lisp
+++ b/glib/glib.lisp
@@ -26,7 +26,13 @@
            #:g-idle-add
            #:g-timeout-add-full
            #:g-source-remove
-           #:at-finalize)
+           #:at-finalize
+           #:with-g-error
+           #:with-catching-to-g-error
+           #:g-error-condition
+           #:g-error-condition-domain
+           #:g-error-condition-code
+           #:g-error-condition-message)
   (:documentation
    "Cl-gtk2-glib is wrapper for @a[http://library.gnome.org/devel/glib/]{GLib}."))
 
-- 
1.7.10.4