error handling for dbus added by mario-goulart on Mon Aug 5 16:13:43 2013

Index: dbus.scm
===================================================================
--- dbus.scm	(revision 29516)
+++ dbus.scm	(working copy)
@@ -339,6 +339,34 @@
 	(define make-message (foreign-lambda message-ptr "dbus_message_new_method_call"
 		c-string c-string c-string c-string))
 
+	(define make-error
+		(foreign-lambda* (c-pointer (struct "DBusError")) ()
+		 "DBusError err;
+                  dbus_error_init(&err);
+                  C_return(&err);"))
+
+	(define free-error!
+		(foreign-lambda* void (((c-pointer (struct "DBusError")) err))
+			"dbus_error_free(err);"))
+
+	(define (raise-dbus-error location err)
+		(let ((err-name
+			((foreign-lambda* c-string (((c-pointer (struct "DBusError")) err))
+					  "C_return(err->name);")
+			 err))
+		      (err-message
+		       ((foreign-lambda* c-string (((c-pointer (struct "DBusError")) err))
+					 "C_return(err->message);")
+			err)))
+		  (free-error! err)
+		  (signal
+		   (make-composite-condition
+		    (make-property-condition 'dbus-call)
+		    (make-property-condition
+		     'exn 
+		     'location location
+		     'message (string-append "(" err-name "): " err-message))))))
+
 	;; todo: garbage-collect this
 	(define make-iter-append
 		(foreign-lambda* message-iter-ptr ((message-ptr msg))
@@ -679,22 +707,20 @@
 				(for-each (lambda (parm)
 					(iter-append-basic iter parm))	params)
 				(free-iter iter)
-				(let* ([reply-msg ((foreign-lambda* message-ptr ((connection-ptr conn) (message-ptr msg))
-							;; idealistic code here; todo: error checking
-							;; todo: timeout comes from where?  (make-parameter) maybe
-							"DBusMessage *reply;
-							DBusError error;
-							dbus_error_init (&error);
-							reply = dbus_connection_send_with_reply_and_block(conn, msg, 5000, &error);
-							if (dbus_error_is_set (&error))
-								fprintf (stderr, \"Error %s: %s\\n\", error.name, error.message);
-							else
-								fprintf (stderr, \"reply signature %s\\n\", dbus_message_get_signature(reply));
-							dbus_message_unref(msg);
-							C_return(reply);") conn msg) ]
-						[reply-iter (make-iter reply-msg)]
-						[reply-args (iter->list reply-iter)] )
-					reply-args)))))
+				(let* ([err (make-error)]
+				       [reply-msg
+								((foreign-lambda* message-ptr ((connection-ptr conn)
+																							 (message-ptr msg)
+																							 ((c-pointer (struct "DBusError")) err))
+							  ;; todo: timeout comes from where?  (make-parameter) maybe
+							  "DBusMessage *reply;
+							   reply = dbus_connection_send_with_reply_and_block(conn, msg, 5000, err);
+							   dbus_message_unref(msg);
+							   C_return(reply);") conn msg err) ])
+				  (if reply-msg
+				      (let ([reply-iter (make-iter reply-msg)])
+								(iter->list reply-iter))
+				      (raise-dbus-error 'call err)))))))
 
 	(set! make-method-proxy (lambda (context name)
 		(let ([service (symbol->string (vector-ref context context-idx-service))]