From 435110cf3c548043efa81f14cdf36d2553b132a9 Mon Sep 17 00:00:00 2001 From: Yorhel Date: Thu, 13 Jun 2013 12:40:46 +0200 Subject: Initial commit ...with so many things left to do --- COPYING | 20 ++++++ dbush | 247 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 267 insertions(+) create mode 100644 COPYING create mode 100755 dbush 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 ' 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 ' 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"; +} -- cgit v1.2.3