user-tools/dbus-call

   1 #!/usr/bin/env perl
   2
   3 =pod
   4
   5 =head1 NAME
   6
   7 dbus-call - Browse DBus and call its methods
   8
   9 =head1 SYNOPSIS
  10
  11 dbus-call [I<OPTIONS>] [I<SERVICE> [I<OBJECT> [I<INTERFACE> [I<METHOD> [I<ARGUMENTS>]]]]]
  12
  13 =head1 DESCRIPTION
  14
  15 May leave out any parameters from the right,
  16 in which case possible values for the first left-out parameter are listed.
  17
  18 =head1 OPTIONS
  19
  20 =over 4
  21
  22 =item --system
  23
  24 Connect to the system DBus.
  25
  26 =item --session
  27
  28 Connect to the session DBus.
  29
  30 =back
  31
  32 =cut
  33
  34 use Net::DBus;
  35 use JSON;
  36 use Data::Dumper;
  37 use Getopt::Long qw/:config no_ignore_case no_bundling no_getopt_compat no_auto_abbrev require_order/;
  38 use Pod::Usage;
  39 use XML::Hash::LX;
  40
  41
  42 GetOptions(
  43         'system' => sub{ $Bus = Net::DBus->system; },
  44         'session' => sub{ $Bus = Net::DBus->session; },
  45         'help' => sub{ pod2usage(-exitval=>0, -verbose=>99); },
  46 ) or pod2usage(-exitval=>2, -verbose=>99);
  47
  48
  49 $Bus = Net::DBus->find unless defined $Bus;
  50
  51 sub dbus_call
  52 {
  53         my ($servicename, $objpath, $interface, $methodname, @methodargs) = @_;
  54         $interface = $servicename if not defined $interface;
  55         my $service = $Bus->get_service($servicename);
  56         my $object = $service->get_object($objpath, $interface);
  57         # TODO: convert arguments in @methodargs to the appropriative data type
  58         return $object->$methodname(@methodargs);
  59 }
  60
  61
  62 ($ServiceName, $ObjPath, $Interface, $MethodName, @MethodArgs) = @ARGV;
  63
  64
  65 if(not defined $ServiceName)
  66 {
  67         my $services = dbus_call("org.freedesktop.DBus", "/org/freedesktop/DBus", undef, "ListNames");
  68         $\ = "\n";
  69         print $_ for @$services;
  70         exit;
  71 }
  72
  73 sub discover_service
  74 {
  75         my $servicename = shift;
  76         my $basepath = shift;
  77         my $thispath = $basepath || "/";
  78
  79         my @objs = ();
  80         my $xmlstr = dbus_call($servicename, $thispath, "org.freedesktop.DBus.Introspectable", "Introspect");
  81         my $xmlhash = xml2hash($xmlstr, attr=>'--', array=>1);
  82
  83         for my $node (@{$xmlhash->{'node'}})
  84         {
  85                 for my $node (@{$node->{'node'}})
  86                 {
  87                         my $nodename = $node->{'--name'};
  88                         my $path = "$basepath/$nodename";
  89                         push @objs, {
  90                                 '_type' => 'node',
  91                                 'objpath' => $path,
  92                         };
  93                         push @objs, discover_service($servicename, $path);
  94                 }
  95                 for my $interface (@{$node->{'interface'}})
  96                 {
  97                         my $ifacename = $interface->{'--name'};
  98                         for my $callable (@{$interface->{'method'}}, @{$interface->{'signal'}})
  99                         {
 100                                 my @args = @{$callable->{'arg'}};
 101                                 push @objs, {
 102                                         '_type' => 'method',  # TODO: distinguish methods from signals
 103                                         'objpath' => $thispath,
 104                                         'interface' => $ifacename,
 105                                         'method' => $callable->{'--name'},
 106                                         'input' => [grep {$_->{'--direction'} ne 'out'} @args],
 107                                         'output' => [grep {$_->{'--direction'} eq 'out'} @args],
 108                                 };
 109                         }
 110                 }
 111         }
 112         return @objs;
 113 }
 114
 115 sub describe_arguments
 116 {
 117         my $arglistref = shift;
 118         return "(" . join(", ", map {sprintf "%s:%s", $_->{'--type'}, $_->{'--name'}} @$arglistref) . ")";
 119 }
 120
 121 if(not defined $ObjPath or not defined $Interface or not defined $MethodName)
 122 {
 123         my $td_headers_shown = 0;
 124         for my $obj (discover_service($ServiceName, $ObjPath || ""))
 125         {
 126                 $\ = "\n";
 127                 #print Dumper $obj;
 128                 if($obj->{'_type'} eq 'method')
 129                 {
 130                         next if defined $Interface and $Interface ne $obj->{'interface'};
 131
 132                         if(not $td_headers_shown) { print join "\t", qw/OBJECT INTERFACE METHOD INPUT OUTPUT/; $td_headers_shown = 1; }
 133                         my $methodargs_description = describe_arguments($obj->{'input'});
 134                         my $returnvalues_description = describe_arguments($obj->{'output'});
 135                         print join "\t", $obj->{'objpath'}, $obj->{'interface'}, $obj->{'method'}, $methodargs_description, $returnvalues_description;
 136                 }
 137         }
 138         exit;
 139 }
 140
 141 $reply = dbus_call($ServiceName, $ObjPath, $Interface, $MethodName, @MethodArgs);
 142 print encode_json($reply);