Fixes for dbus example

git-svn-id: trunk@4883 -

packages/base/dbus/dbus.pas

@@ -33,6 +33,8 @@ unit dbus;
 
 {$minenumsize 4}
 
+{$packrecords c}
+
 { FPC 2.0.2 compatibility code }
 {$ifdef win32}
   {$define windows}

packages/base/dbus/example/busexample.pp

@@ -12,32 +12,320 @@ uses
   ctypes,
   dbus;
 
-procedure BusSend;
+const
+  SINTAX_TEXT = 'Syntax: dbus-example [send|receive|listen|query] [<param>]';
+
+var
+  err: DBusError;
+  conn: PDBusConnection;
+  ret: cint;
+
+{
+ * Send a broadcast signal
+ }
+procedure BusSend(sigvalue: PChar);
+var
+  msg: PDBusMessage;
+  args: DBusMessageIter;
+  serial: dbus_uint32_t = 0;
 begin
+  WriteLn('Sending signal with value ', string(sigvalue));
+
+  { Request the name of the bus }
+  ret := dbus_bus_request_name(conn, 'test.signal.source', DBUS_NAME_FLAG_REPLACE_EXISTING, @err);
+
+  if dbus_error_is_set(@err) <> 0 then
+  begin
+    WriteLn('Name Error: ' + err.message);
+    dbus_error_free(@err);
+  end;
+
+  if ret <> DBUS_REQUEST_NAME_REPLY_PRIMARY_OWNER then Exit;
+
+  // create a signal & check for errors
+  msg := dbus_message_new_signal('/test/signal/Object', // object name of the signal
+                                 'test.signal.Type', // interface name of the signal
+                                 'Test'); // name of the signal
+  if (msg = nil) then
+  begin
+    WriteLn('Message Null');
+    Exit;
+  end;
+
+  // append arguments onto signal
+  dbus_message_iter_init_append(msg, @args);
+  if (dbus_message_iter_append_basic(@args, DBUS_TYPE_STRING, @sigvalue) = 0) then
+  begin
+    WriteLn('Out Of Memory!');
+    Exit;
+  end;
+
+  // send the message and flush the connection
+  if (dbus_connection_send(conn, msg, @serial) = 0) then
+  begin
+    WriteLn('Out Of Memory!');
+    Exit;
+  end;
+  
+  dbus_connection_flush(conn);
+
+  WriteLn('Signal Sent');
 
+  // free the message and close the connection
+  dbus_message_unref(msg);
 end;
 
+{
+ * Listens for signals on the bus
+ }
 procedure BusReceive;
+var
+  msg: PDBusMessage;
+  args: DBusMessageIter;
+  sigvalue: PChar;
 begin
+  WriteLn('Listening for signals');
 
+  { Request the name of the bus }
+  ret := dbus_bus_request_name(conn, 'test.signal.sink', DBUS_NAME_FLAG_REPLACE_EXISTING, @err);
+
+  if dbus_error_is_set(@err) <> 0 then
+  begin
+    WriteLn('Name Error: ' + err.message);
+    dbus_error_free(@err);
+  end;
+
+  // add a rule for which messages we want to see
+  dbus_bus_add_match(conn, 'type=''signal'',interface=''test.signal.Type''', @err); // see signals from the given interface
+  dbus_connection_flush(conn);
+  if (dbus_error_is_set(@err) <> 0) then
+  begin
+    WriteLn('Match Error (', err.message, ')');
+    Exit;
+  end;
+  WriteLn('Match rule sent');
+
+  // loop listening for signals being emmitted
+  while (true) do
+  begin
+
+    // non blocking read of the next available message
+    dbus_connection_read_write(conn, 0);
+    msg := dbus_connection_pop_message(conn);
+
+    // loop again if we haven't read a message
+    if (msg = nil) then
+    begin
+      sleep(1);
+      Continue;
+    end;
+
+    // check if the message is a signal from the correct interface and with the correct name
+    if (dbus_message_is_signal(msg, 'test.signal.Type', 'Test') <> 0) then
+    begin
+      // read the parameters
+      if (dbus_message_iter_init(msg, @args) = 0) then
+         WriteLn('Message Has No Parameters')
+      else if (DBUS_TYPE_STRING <> dbus_message_iter_get_arg_type(@args)) then
+         WriteLn('Argument is not string!')
+      else
+         dbus_message_iter_get_basic(@args, @sigvalue);
+
+      WriteLn('Got Signal with value ', sigvalue);
+    end;
+
+    // free the message
+    dbus_message_unref(msg);
+  end;
 end;
 
-procedure BusListen;
+procedure reply_to_method_call(msg: PDBusMessage; conn: PDBusConnection);
+var
+  reply: PDBusMessage;
+  args: DBusMessageIter;
+  stat: Boolean = true;
+  level: dbus_uint32_t = 21614;
+  serial: dbus_uint32_t = 0;
+  param: PChar = '';
 begin
+   // read the arguments
+   if (dbus_message_iter_init(msg, @args) = 0) then
+      WriteLn('Message has no arguments!')
+   else if (DBUS_TYPE_STRING <> dbus_message_iter_get_arg_type(@args)) then
+      WriteLn('Argument is not string!')
+   else
+      dbus_message_iter_get_basic(@args, @param);
+
+   WriteLn('Method called with ', param);
 
+   // create a reply from the message
+   reply := dbus_message_new_method_return(msg);
+
+   // add the arguments to the reply
+   dbus_message_iter_init_append(reply, @args);
+   if (dbus_message_iter_append_basic(@args, DBUS_TYPE_BOOLEAN, @stat) = 0) then
+   begin
+     WriteLn('Out Of Memory!');
+     Exit;
+   end;
+   if (dbus_message_iter_append_basic(@args, DBUS_TYPE_UINT32, @level) = 0) then
+   begin
+     WriteLn('Out Of Memory!');
+     Exit;
+   end;
+
+   // send the reply && flush the connection
+   if (dbus_connection_send(conn, reply, @serial) = 0) then
+   begin
+     WriteLn('Out Of Memory!');
+     Exit;
+   end;
+   dbus_connection_flush(conn);
+
+   // free the reply
+   dbus_message_unref(reply);
 end;
 
-procedure BusQuery;
+{
+ * Server that exposes a method call and waits for it to be called
+ }
+procedure BusListen;
+var
+  msg, reply: PDBusMessage;
+  args: DBusMessageIter;
+  param: PChar;
 begin
+  WriteLn('Listening for method calls');
+
+  { Request the name of the bus }
+  ret := dbus_bus_request_name(conn, 'test.method.server', DBUS_NAME_FLAG_REPLACE_EXISTING, @err);
 
+  if dbus_error_is_set(@err) <> 0 then
+  begin
+    WriteLn('Name Error: ' + err.message);
+    dbus_error_free(@err);
+  end;
+
+  if ret <> DBUS_REQUEST_NAME_REPLY_PRIMARY_OWNER then Exit;
+
+  // loop, testing for new messages
+  while (true) do
+  begin
+    // non blocking read of the next available message
+    dbus_connection_read_write(conn, 0);
+    msg := dbus_connection_pop_message(conn);
+
+    // loop again if we haven't got a message
+    if (msg = nil) then
+    begin
+      sleep(1);
+      Continue;
+    end;
+
+    // check this is a method call for the right interface & method
+    if (dbus_message_is_method_call(msg, 'test.method.Type', 'Method') <> 0) then
+       reply_to_method_call(msg, conn);
+
+    // free the message
+    dbus_message_unref(msg);
+  end;
 end;
 
-const
-  SINTAX_TEXT = 'Syntax: dbus-example [send|receive|listen|query] [<param>]';
+{
+ * Call a method on a remote object
+ }
+procedure BusCall(param: PChar);
 var
-  err: DBusError;
-  conn: PDBusConnection;
-  ret: cint;
+  msg: PDBusMessage;
+  args: DBusMessageIter;
+  pending: PDBusPendingCall;
+  stat: Boolean;
+  level: dbus_uint32_t;
+begin
+  WriteLn('Calling remote method with ', param);
+
+  { Request the name of the bus }
+  ret := dbus_bus_request_name(conn, 'test.method.caller', DBUS_NAME_FLAG_REPLACE_EXISTING, @err);
+
+  if dbus_error_is_set(@err) <> 0 then
+  begin
+    WriteLn('Name Error: ' + err.message);
+    dbus_error_free(@err);
+  end;
+
+  if ret <> DBUS_REQUEST_NAME_REPLY_PRIMARY_OWNER then Exit;
+
+  // create a new method call and check for errors
+  msg := dbus_message_new_method_call('test.method.server', // target for the method call
+                                      '/test/method/Object', // object to call on
+                                      'test.method.Type', // interface to call on
+                                      'Method'); // method name
+  if (msg = nil) then
+  begin
+    WriteLn('Message Null');
+    Exit;
+  end;
+
+  // append arguments
+  dbus_message_iter_init_append(msg, @args);
+  if (dbus_message_iter_append_basic(@args, DBUS_TYPE_STRING, @param) = 0) then
+  begin
+    WriteLn('Out Of Memory!');
+    Exit;
+  end;
+
+  // send message and get a handle for a reply
+  if (dbus_connection_send_with_reply(conn, msg, @pending, -1) = 0) then // -1 is default timeout
+  begin
+    WriteLn('Out Of Memory!');
+    Exit;
+  end;
+  if (pending = nil) then
+  begin
+    WriteLn('Pending Call Null');
+    Exit;
+  end;
+  dbus_connection_flush(conn);
+
+  WriteLn('Request Sent');
+
+  // free message
+  dbus_message_unref(msg);
+
+  // block until we recieve a reply
+  dbus_pending_call_block(pending);
+
+  // get the reply message
+  msg := dbus_pending_call_steal_reply(pending);
+  if (msg = nil) then
+  begin
+    WriteLn('Reply Null');
+    Exit;
+  end;
+  // free the pending message handle
+  dbus_pending_call_unref(pending);
+
+  // read the parameters
+  if (dbus_message_iter_init(msg, @args) = 0) then
+     WriteLn('Message has no arguments!')
+  else if (DBUS_TYPE_BOOLEAN <> dbus_message_iter_get_arg_type(@args)) then
+     WriteLn('Argument is not boolean!')
+  else
+     dbus_message_iter_get_basic(@args, @stat);
+
+  if (dbus_message_iter_next(@args) = 0) then
+     WriteLn('Message has too few arguments!')
+  else if (DBUS_TYPE_UINT32 <> dbus_message_iter_get_arg_type(@args)) then
+     WriteLn('Argument is not int!')
+  else
+     dbus_message_iter_get_basic(@args, @level);
+
+  WriteLn('Got Reply: ', stat, ', ', level);
+
+  // free reply
+  dbus_message_unref(msg);
+end;
+
 begin
   { Initializes the errors }
   dbus_error_init(@err);
@@ -53,26 +341,15 @@ begin
   
   if conn = nil then Exit;
   
-  { Request the name of the bus }
-  ret := dbus_bus_request_name(conn, 'test.method.server', DBUS_NAME_FLAG_REPLACE_EXISTING, @err);
-
-  if dbus_error_is_set(@err) <> 0 then
-  begin
-    WriteLn('Name Error: ' + err.message);
-    dbus_error_free(@err);
-  end;
-  
-  if ret <> DBUS_REQUEST_NAME_REPLY_PRIMARY_OWNER then Exit;
-
   { Parses parameters }
   
   if (ParamCount <> 1) and (ParamCount <> 2) then WriteLn(SINTAX_TEXT)
   else
   begin
-    if ParamStr(1) = 'send' then BusSend
-    else if ParamStr(1) = 'receive' then BusReceive
-    else if ParamStr(1) = 'listen' then BusListen
-    else if ParamStr(1) = 'query' then BusQuery
+    if ParamStr(1) = 'send' then BusSend(PChar(ParamStr(2)))
+    else if ParamStr(1) = 'receive' then BusReceive()
+    else if ParamStr(1) = 'listen' then BusListen()
+    else if ParamStr(1) = 'call' then BusCall(PChar(ParamStr(2)))
     else WriteLn(SINTAX_TEXT);
   end;