summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorYorhel <git@yorhel.nl>2013-06-13 12:40:46 +0200
committerYorhel <git@yorhel.nl>2013-06-13 12:40:46 +0200
commit435110cf3c548043efa81f14cdf36d2553b132a9 (patch)
treeed83ddd97eadf15c3b32f6175480e7545b6a9e9c
Initial commit
...with so many things left to do
-rw-r--r--COPYING20
-rwxr-xr-xdbush247
2 files changed, 267 insertions, 0 deletions
diff --git a/COPYING b/COPYING
new file mode 100644
index 0000000..b91631b
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,20 @@
+Copyright (c) 2013 Yoran Heling
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
diff --git a/dbush b/dbush
new file mode 100755
index 0000000..8c6ec80
--- /dev/null
+++ b/dbush
@@ -0,0 +1,247 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Net::DBus;
+use Net::DBus::Reactor;
+use Term::ReadLine;
+use Getopt::Long;
+
+# TODO: Loading a dbushrc with commands to execute on startup
+# TODO: Ctrl+C handling
+# TODO: Tab completion
+# TODO: Listing interfaces/methods/signals/properties
+# TODO: Method invocation
+# TODO: Convenient property handling?
+# TODO: Capturing/displaying signals
+# TODO: Displaying NameOwnerChanged notifications
+# TODO: DOCUMENTATION!
+
+# XXX: This script makes use of several undocumented and/or internal features
+# of Net::DBus. I'll have to figure out how portable those are. For now I've
+# marked all these occurences with "XXX: Undocumented".
+
+
+die "This command requires the Term::ReadLine::Gnu module, please install it!"
+ if Term::ReadLine->ReadLine() ne 'Term::ReadLine::Gnu';
+
+
+my($conf_system, $conf_session);
+GetOptions(
+ system => \$conf_system,
+ session => \$conf_session,
+);
+
+my $histfile = "$ENV{HOME}/.dbush_history";
+
+my $bus = $conf_session ? Net::DBus->session : $conf_system ? Net::DBus->system : Net::DBus->find;
+my $term = Term::ReadLine->new('dbush');
+my $reactor = Net::DBus::Reactor->main();
+my $curobj; # Current Net::DBus::RemoteObject that we're cd'ed to
+my $objalive; # Whether the service providing $curobj is alive
+
+
+# Comparison function for connection names, in order to nicely sort stuff like ":1.10".
+sub name_cmp {
+ my($fa, $fb) = ($a, $b);
+ return $a cmp $b if !($fa =~ s/^://) || !($fb =~ s/^://);
+ my @ea = split /\./, $fa;
+ my @eb = split /\./, $fb;
+ while(@ea) {
+ my($ea, $eb) = (shift(@ea)||'', shift(@eb)||'');
+ my $c = $ea =~ /^[1-9][0-9]*$/ && $eb =~ /^[1-9][0-9]*$/ ? $ea <=> $eb : $ea cmp $eb;
+ return $c if $c;
+ }
+ return 0;
+}
+
+
+sub getprompt {
+ return '[dbush] ' if !$curobj;
+ sprintf '[%s %s%s] ',
+ $curobj->get_service->get_service_name,
+ $curobj->get_object_path,
+ $objalive ? '' : ' (dead)';
+}
+
+
+# Resolve a path relative to $curobj or '/'
+sub resolvepath {
+ my($path, $obj) = @_;
+ my @path = split /\//, $path;
+ $obj ||= $curobj;
+
+ # If the given path is relative, get a sane root.
+ my @root;
+ if(!(@path && $path[0] eq '') && $obj) {
+ @root = split /\//, $obj->get_object_path;
+ shift @root; # Remove first empty element to get rid of the / prefix
+ }
+
+ for (@path) {
+ next if $_ eq '' || $_ eq '.';
+ if($_ eq '..') {
+ pop @root;
+ } else {
+ push @root, $_;
+ }
+ }
+ return '/'.join '/', @root;
+}
+
+
+sub resolveobj {
+ my($path, $obj) = @_;
+ return ($obj||$curobj)->get_service()->get_object(resolvepath $path, $obj);
+}
+
+
+sub asyncprint(&) {
+ # Ugly hack to erase the readline prompt for a bit so that we can output
+ # async notification lines. Doesn't work well if the prompt consumes multiple
+ # lines on the terminal.
+ print "\r\x1B[K";
+
+ shift->();
+
+ $term->rl_set_prompt(getprompt);
+ $term->rl_on_new_line;
+ $term->rl_redisplay;
+}
+
+
+
+
+my %cmd;
+sub cmd($&) {
+ my $n = shift;
+ $cmd{$n} = shift;
+}
+
+cmd names => sub {
+ my $o = $bus->get_bus_object;
+ my %names;
+ for(@{$o->ListNames()}) {
+ next if $_ eq 'org.freedesktop.DBus';
+ my $n = /^:/? $_ : $o->GetNameOwner($_);
+ $names{$n} ||= [];
+ push @{$names{$n}}, $_ if !/^:/;
+ }
+ for my $n (sort name_cmp keys %names) {
+ printf " %-8s%s\n", $n, join '', map " $_", sort @{$names{$n}};
+ }
+};
+
+
+cmd sw => sub {
+ my($name, $path) = split /\s+/, shift;
+ my $o = $bus->get_bus_object;
+ return undef $curobj if !$name;
+ my @n = grep $_ ne 'org.freedesktop.DBus' && /\Q$name/i, @{$o->ListNames()};
+ return print "No connection found that matches '$name'.\n" if !@n;
+
+ # If there are multiple matches, pick the shortest one (e.g. '1.1' matches
+ # both '1.1' and '1.10', assume we meant the first).
+ my $n = [sort { length($a) <=> length($b) } @n]->[0];
+ my $un = $o->GetNameOwner($n);
+ printf "%s is owned by %s.\n", $n, $un if $un ne $n;
+ $objalive = 1;
+
+ $path ||= '/';
+ ($path = $n) =~ s/\./\//g if $path eq '-';
+ $curobj = resolveobj $path, $bus->get_service($n)->get_object('/');
+};
+
+
+cmd ls => sub {
+ my @args = split /\s+/, shift;
+ my($path, $level) = ('', 1);
+ for(@args) {
+ /^-[rR]$/ and ($level = 999), next;
+ $path = $_;
+ }
+ return print "Not associated with a connection, use 'sw <name>' first\n" if !$curobj;
+ return print "Current name is not associated with a connection\n" if !$objalive;
+
+ my $t; $t = sub {
+ my($depth, $obj, $name) = @_;
+ my @r = ($name);
+ return @r if $depth <= 0;
+ my $ins = eval { $obj->_introspector() }; # XXX: Undocumented
+ my @l = $ins ? $ins->list_children() : ();
+ printf '%s: %s', $obj->get_object_path, $@ if !$ins;
+ for my $i (0..$#l) {
+ my @n = $t->($depth-1, resolveobj($l[$i], $obj), $l[$i]);
+ push @r, ($i == $#l ? '└' : '├').'── '.shift(@n);
+ push @r, map +($i == $#l ? ' ' : '│').' '.$_, @n;
+ }
+ @r;
+ };
+
+ $path = resolvepath $path;
+ print "$_\n" for ($t->($level, resolveobj($path), $path));
+};
+
+
+cmd cd => sub {
+ my $path = shift;
+ # TODO: Verify that the object exists? (Ping() or Introspect())
+ # TODO: What should a 'cd' without arguments go to?
+ return print "Not associated with a connection, use 'sw <name>' first\n" if !$curobj;
+ $curobj = resolveobj $path;
+};
+
+
+
+$term->ReadHistory($histfile);
+$term->callback_handler_install(getprompt, sub {
+ my $msg = shift;
+ exit if !defined $msg;
+ my($cmd, $args) = $msg =~ /^\s*([a-z]+)(.*)$/;
+ return printf "Unknown command '%s'.\n", $cmd||''
+ if !$cmd || !$cmd{$cmd};
+ $args =~ s/^\s+//;
+ $args =~ s/\s+$//;
+ $cmd{$cmd}->($args);
+ $term->addhistory($msg);
+ $term->rl_set_prompt(getprompt);
+
+ # Flush any object caching in Net::DBus after each command to ensure that we
+ # have fresh data on the next command.
+ # TODO: Caching is completely disabled this way, even while it certainly
+ # isn't such a bad idea in many situations. We probably want to make this
+ # caching behaviour configurable.
+ if($curobj) {
+ # XXX: Undocumented
+ $curobj->get_service()->{objects} = {};
+ $curobj->{introspected} = 0;
+ }
+});
+$reactor->add_read(0, Net::DBus::Callback->new(method => sub { $term->callback_read_char }));
+
+
+$bus->get_bus_object()->connect_to_signal(NameOwnerChanged => sub {
+ my($name, $old, $new) = @_;
+ return if !$curobj || $name ne $curobj->get_service()->get_service_name;
+ asyncprint {
+ # Message strings inspired by gdbus
+ if($new) {
+ $objalive = 1;
+ # Unique bus names are never re-used, so $name and $new are always
+ # different strings if we assume that the $name has been available
+ # earlier.
+ print "** The name $name is now owned by $new\n";
+ } else {
+ $objalive = 0;
+ print "** The name $name does not have an owner\n";
+ }
+ };
+});
+
+
+$reactor->run();
+
+END {
+ $term->WriteHistory($histfile);
+ print "\n";
+}