#!/usr/bin/env perl
# dbus-name -- display D-Bus service names currently on the bus
#
# (c) 2012-2016 Mantas Mikulėnas <grawity@gmail.com>
# Released under the MIT License <https://spdx.org/licenses/MIT>
use v5.14;
use warnings;
use Getopt::Long qw(:config bundling);
use Net::DBus;
use Net::DBus::Reactor;

BEGIN {
	if (eval {require Nullroute::Lib}) {
		Nullroute::Lib->import(qw(_warn _err _die));
	} else {
		our ($arg0, $warnings, $errors);
		$::arg0 = (split m!/!, $0)[-1];
		sub _warn  { warn "warning: @_\n"; ++$::warnings; }
		sub _err   { warn "error: @_\n"; ! ++$::errors; }
		sub _die   { _err(@_); exit 1; }
	}
}

my $bus;
my $busaddr;
my $err = 0;
my $activate = 0;
my $quiet = 0;
my $list = 0;
my $wait = 0;
my $watch = 0;
my $color = undef;

sub read_line {
	my ($file) = @_;

	if (open my $fh, "<", $file) {
		my $line = <$fh>;
		chomp $line;
		close $fh;
		return $line;
	}
}

sub get_conn_pid {
	my ($conn) = @_;

	if (length($conn)) {
		my $obj = $bus->get_bus_object;
		return eval {$obj->GetConnectionUnixProcessID($conn)};
	} else {
		return undef;
	}
}

sub get_pid_cmdline {
	my ($pid) = @_;

	read_line("/proc/$pid/comm");
}

sub get_conn_name {
	my ($conn) = @_;

	my $pid = get_conn_pid($conn);
	if ($pid) {
		my $name = get_pid_cmdline($pid) // "?";
		return "$pid/$name";
	} else {
		return undef;
	}
}

sub usage {
	say for
	"Usage: $::arg0 {-y|-e|-a ADDRESS} [-q] [-A] NAME...",
	"       $::arg0 {-y|-e|-a ADDRESS} [-q] [-A] --list",
	"       $::arg0 {-y|-e|-a ADDRESS} [-q] {--wait|--wait-any} NAME...",
	"       $::arg0 {-y|-e|-a ADDRESS} [-q] --watch",
	"",                       #
	"  -y, --system           Connect to the system bus",
	"  -e, --session          Connect to the session bus",
	"  -u, --user             Connect to the user bus",
	"  -a, --address=ADDR     Connect to given D-Bus address",
	"",
	"  -A, --activate         Try to launch services using D-Bus activation",
	"  -l, --list             List all owned names (or activatable names with -A)",
	"  --wait NAME...         Wait for listed names to appear on bus",
	"  --wait-any NAME...     Wait for /any/ of listed names to appear",
	"  -w, --watch            Watch bus for name owner changes",
	"",
	"  -q, --quiet            Remain silent, just set exit code if name exists",
	"                         In wait/watch mode: don't show PIDs and unique names",
	"  --[no-]color           Always/never use colored output",
	"",
	"Without explicit bus specification, the heuristics implemented by Net::DBus",
	"will be used (session if \$DBUS_SESSION_BUS_ADDRESS is set, system otherwise).",
	"",
	"The \"--wait NAME\" mode does not care if some names go away after appearing.",
}

# Option parser

GetOptions(
	"help"		=> sub { usage(); exit; },
	"A|activate"	=> \$activate,
	"a|address=s"	=> \$busaddr,
	"color!"	=> \$color,
	"l|list+"	=> \$list,
	"q|quiet"	=> \$quiet,
	"e|session"	=> sub { $busaddr = "session"; },
	"y|system"	=> sub { $busaddr = "system"; },
	"u|user"	=> sub { $busaddr = "user"; },
	"w|wait"	=> \$wait,
	"wait-any"	=> sub { $wait = "any"; },
	"watch"		=> \$watch,
) or exit 2;

$color //= -t 1 && length($ENV{TERM} // "") > 0;

# Main code

my %color = (
	"+"   => $color ? "\e[1;32m" : "",
	"~"   => $color ? "\e[1;33m" : "",
	"-"   => $color ? "\e[1;31m" : "",
	gray  => $color ? "\e[1;30m" : "",
	reset => $color ? "\e[m"     : "",
);

for ($busaddr) {
	if (!defined $_) {
		$bus = Net::DBus->find;
	}
	elsif ($_ eq "system") {
		$bus = Net::DBus->system;
	}
	elsif ($_ eq "session") {
		$bus = Net::DBus->session;
	}
	elsif ($_ eq "user") {
		my $rundir = $ENV{XDG_RUNTIME_DIR};
		if (!defined $rundir) {
			_die("connecting to user bus requires XDG_RUNTIME_DIR");
		}
		$bus = Net::DBus->new("unix:path=$rundir/bus");
	}
	else {
		$bus = Net::DBus->new($busaddr);
	}
}

$|++; # autoflush stdout, to make piping into files/apps work

if ($list) {
	_warn("extra arguments ignored with --list") if @ARGV;
	my $obj = $bus->get_bus_object;
	my $names = $activate
			? $obj->ListActivatableNames
			: $obj->ListNames;
	my @names = @$names;
	if ($quiet) {
		@names = grep {!/^:/} @names;
	}
	if (eval {require Sort::Naturally}) {
		@names = Sort::Naturally::nsort(@names);
	} else {
		@names = sort @names;
	}
	if ($list > 1) {
		for my $name (@names) {
			my $owner = $bus->get_service_owner($name);
			my $proc = get_conn_name($owner);
			say $name,
				" ", $owner // "(none)",
				" [", $proc // "none", "]";
			$owner or ++$err;
		}
	} else {
		say for @names;
	}
} elsif (@ARGV and $wait) {
	my $obj = $bus->get_bus_object;
	my @wanted = @ARGV;
	$obj->connect_to_signal("NameOwnerChanged", sub {
		my ($bus_name, $old_owner, $new_owner) = @_;
		my $is_wanted = grep {$_ eq $bus_name} @wanted;
		if ($is_wanted && $new_owner) {
			say "$bus_name taken by $new_owner" unless $quiet;
			# Remove from the wanted list
			@wanted = grep {$_ ne $bus_name} @wanted;
			exit 0 if $wait eq 'any' || !@wanted;
		}
	});
	my $current = $obj->ListNames;
	# Filter out already-published names before starting the loop
	# this is effectively "@wanted -= @$current"
	my %current = map {$_ => 1} @$current;
	@wanted = grep {!$current{$_}} @wanted;
	exit 0 if !@wanted;
	Net::DBus::Reactor->main->run;
} elsif ($wait || $watch) {
	my $obj = $bus->get_bus_object;
	$obj->connect_to_signal("NameOwnerChanged", sub {
		my ($bus_name, $old_owner, $new_owner) = @_;
		return if $bus_name =~ /^:/;
		my $state = length($old_owner)
				? length($new_owner) ? "~" : "-"
				: length($new_owner) ? "+" : "?";
		if ($quiet) {
			say $color{$state}, $state, $color{"reset"},
				" ", $bus_name;
		} else {
			my $new_proc = get_conn_name($new_owner);
			say $color{$state}, $state, $color{"reset"},
				" ", $bus_name,
				" ",
					length($old_owner) ? $color{"-"} : $color{"gray"},
					length($old_owner) ? $old_owner : "(none)",
					$color{"reset"},
				" ",
					length($new_owner) ? $color{"+"} : $color{"gray"},
					length($new_owner) ? $new_owner : "(none)",
					$color{"reset"},
				length($new_owner) ? (" [", $new_proc // "none", "]") : ();
		}
	});
	Net::DBus::Reactor->main->run;
} elsif (@ARGV) {
	my $obj = $bus->get_bus_object;
	for my $name (@ARGV) {
		if ($activate) {
			eval {$bus->get_service($name)} or warn "$@";
		}
		my $owner = $bus->get_service_owner($name);
		if (!$quiet) {
			my $proc = get_conn_name($owner);
			say $name,
				" ", $owner // "(none)",
				" [", $proc // "none", "]";
		}
		$owner or ++$err;
	}
	exit !!$err;
} else {
	_die("at least one bus name must be provided");
}
