#!/usr/bin/perl

use strict;
use warnings;
use Net::DBus ':typing';
use Net::DBus::Reactor;
use Term::ReadLine;
use Getopt::Long;
use Data::Dumper 'Dumper';

# TODO: Loading a dbushrc with commands to execute on startup
# TODO: Ctrl+C handling
# TODO: Convenient property handling
# TODO: Capturing/displaying signals
# TODO: Displaying NameOwnerChanged notifications
# TODO: Fancy colors everywhere
# 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

$Data::Dumper::Terse = 1;


# 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 !~ /^\// && $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 flushcache {
  return if !$curobj;
  # XXX: Undocumented. The entire caching behaviour in Net::DBus is totally
  # undocumented, even.
  $curobj->get_service()->{objects} = {};
  $curobj->{introspected} = 0;
}


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;
}


sub fmt_args {
  my($type, $ins, $itf, $name) = @_;
  my($t, $n) =
    $type eq 'param'  ? ([$ins->get_method_params ($itf, $name)], [$ins->get_method_param_names ($itf, $name)]) :
    $type eq 'return' ? ([$ins->get_method_returns($itf, $name)], [$ins->get_method_return_names($itf, $name)]) :
                        ([$ins->get_signal_params ($itf, $name)], [$ins->get_signal_param_names ($itf, $name)]);
  join ', ', map $ins->to_xml_type($t->[$_]).' '.$n->[$_], 0..$#$t;
}


sub complete_objpath {
  my($args, $obj) = @_;
  $obj ||= $curobj;
  return () if !$obj;
  my($path, $last) = $args =~ /^(?:(.*\/))?([^\/]*)$/;
  $path ||= '';
  $obj = resolveobj $path, $obj;
  my $ins = eval { $obj->_introspector() }; # XXX: Undocumented
  return () if !$ins;
  $term->Attribs->{completion_append_character} = '';
  map "$path$_/", grep /^\Q$last/, $ins->list_children();
}




my %cmd;
sub cmd {
  my $n = shift;
  $cmd{$n} = [ shift, 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('/');
}, sub {
  my $args = shift;
  my $o = $bus->get_bus_object;
  return $o->NameHasOwner(dbus_string $1) ? complete_objpath $2, $bus->get_service($1)->get_object('/') : ()
    if $args =~ /([^ ]+)\s+(.*)$/;
  grep $_ ne 'org.freedesktop.DBus' && /^\Q$args/, @{$o->ListNames()};
};


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));
}, sub {
  (my $arg = shift) =~ s/^-[rR]\s+//;
  return complete_objpath $arg;
};


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;
}, \&complete_objpath;


# TODO: Rename/alias to something shorter
# TODO: List flags such as Deprecated, NoReply and EmitsChangedSignal
# TODO: Add -a or -v option to list "common" interfaces that are otherwise hidden
# TODO: Add option to list only methods, signals and/or properties
# TODO: Add interface name filter
cmd introspect => sub {
  return print "Not associated with a connection, use 'sw <name>' first\n" if !$curobj;
  my $ins = eval { $curobj->_introspector() }; # XXX: Undocumented
  return print $@ if !$ins;

  for my $itf (sort $ins->list_interfaces) {
    print "$itf\n";

    # Don't list details from these three common and obvious interfaces
    next if {map +("org.freedesktop.DBus.$_",1), qw|Introspectable Peer ObjectManager Properties|}->{$itf};

    my @meth = sort $ins->list_methods($itf);
    print "\n" if @meth;
    for my $meth (@meth) {
      my $ret = fmt_args return => $ins, $itf, $meth;
      printf "   method %s(%s)%s\n",
        $meth, fmt_args(param => $ins, $itf, $meth),
          $ret ? " -> ($ret)" : '';
    }

    my @sig = sort $ins->list_signals($itf);
    print "\n" if @sig;
    for my $sig (@sig) {
      printf "   signal %s(%s)\n", $sig,
        fmt_args signal => $ins, $itf, $sig;
    }

    my @prop = sort $ins->list_properties($itf);
    print "\n" if @prop;
    for my $prop (@prop) {
      printf "   property %s %s %s\n",
        $ins->to_xml_type($ins->get_property_type($itf, $prop)),
        $prop, join '',
          ($ins->is_property_readable($itf, $prop)?'r':''),
          ($ins->is_property_writable($itf, $prop)?'w':'');
    }

    print "\n";
  }
};


# TODO: Print the return value in a more D-Bus specific form than what Data::Dumper gives
# TODO: Support specifying an explicit interface
# TODO: Have argument specified in a custom (space-separated) format instead of using eval()
# TODO: Allow specifying argument types (currently possible through calling dbus_*(), but that's ugly)
# TODO: Allow calling methods in an other object (SubObject/Ping)
# TODO: Allow method invocation without prefixing the command with 'call '
cmd call => sub {
  my($cmd, $args) = shift =~ /^([^ ]+)(.*)$/;
  return print "Not associated with a connection, use 'sw <name>' first\n" if !$curobj;
  return print "No method name given\n" if !$cmd;
  my $ins = eval { $curobj->_introspector() }; # XXX: Undocumented
  return print $@ if !$ins;
  my @itf = $ins->has_method($cmd);

  # TODO: No need for this check if we can perform the call without relying on
  # introspection data (e.g. no need to infer argument types)
  return print "Method '$cmd' does not exist\n" if !@itf;
  return print "Method '$cmd' is ambiguous; It is specified in multiple interfaces\n" if @itf > 1;

  my($check, @arg) = eval "(1, $args )";
  return print "Can't parse arguments: $@", if !$check;

  # XXX: Undocumented
  my($check2, @ret) = eval { (1, $curobj->_call_method(Net::DBus::Annotation::dbus_call_sync, $cmd, $itf[0], 1, @arg)); };
  return print $@ if !$check2;
  print Dumper @ret if @ret;
}, sub {
  my($cmd, $args) = shift =~ /^([^ ]+)(.*)$/;
  return () if !$curobj || $args;
  my $ins = eval { $curobj->_introspector() }; # XXX: Undocumented
  $cmd ||= '';
  return () if !$ins;
  grep /^\Q$cmd/, map $ins->list_methods($_), $ins->list_interfaces;
};




$term->ReadHistory($histfile);

$term->Attribs->{completion_function} = sub {
  my($text, $line, $start) = @_;
  $term->Attribs->{completion_append_character} = ' ';
  my $msg = substr $line, 0, $start+length $text;
  $msg =~ s/^\s+//;
  return grep /^\Q$msg/, keys %cmd if $msg !~ / /;
  my $cmd = $msg =~ s/^([^\s]+)\s+// && $1;
  return !$cmd{$cmd} || !$cmd{$cmd}[1] ? () : $cmd{$cmd}[1]->($msg);
};

$term->CallbackHandlerInstall(getprompt, sub {
  my $msg = shift;
  exit if !defined $msg;
  my($cmd, $args) = $msg =~ /^\s*([a-z]+)(.*)$/;
  return if !defined $cmd;
  return printf "Unknown command '%s'.\n", $cmd if !$cmd{$cmd};
  $args =~ s/^\s+//;
  $args =~ s/\s+$//;
  $cmd{$cmd}[0]->($args);
  $term->rl_set_prompt(getprompt);
  flushcache; # TODO: Make configurable
});

# Undo the weird ornament stuff performed in CallbackHandlerInstall().
$term->rl_set_prompt(getprompt);
$term->rl_redisplay;


$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";
}