freepascal.compiler/packages/dbus/examples/busexample.pp

program busexample;

{$ifdef fpc}
  {$mode objfpc}{$H+}
{$endif}

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  SysUtils,
  ctypes,
  dbus;

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: PAnsiChar);
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: PAnsiChar;
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 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: PAnsiChar = '';
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;

{
 * Server that exposes a method call and waits for it to be called
 }
procedure BusListen;
var
  msg, reply: PDBusMessage;
  args: DBusMessageIter;
  param: PAnsiChar;
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;

{
 * Call a method on a remote object
 }
procedure BusCall(param: PAnsiChar);
var
  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);
  
  { Connection }
  conn := dbus_bus_get(DBUS_BUS_SESSION, @err);

  if dbus_error_is_set(@err) <> 0 then
  begin
    WriteLn('Connection Error: ' + err.message);
    dbus_error_free(@err);
  end;
  
  if conn = nil then Exit;
  
  { Parses parameters }
  
  if (ParamCount <> 1) and (ParamCount <> 2) then WriteLn(SINTAX_TEXT)
  else
  begin
    if ParamStr(1) = 'send' then BusSend(PAnsiChar(ParamStr(2)))
    else if ParamStr(1) = 'receive' then BusReceive()
    else if ParamStr(1) = 'listen' then BusListen()
    else if ParamStr(1) = 'call' then BusCall(PAnsiChar(ParamStr(2)))
    else WriteLn(SINTAX_TEXT);
  end;

  { Finalization }
  dbus_connection_close(conn);
end.