mumble/scripts/server/dbus/weblist.pl
Robert 56db3410c5 MAINT: Update copyright notice to 2021 (Part II)
Apparently the first commit (59ae429972)
did not include all files.

Furthermore the used script tended to produce funny results in certain
cases. This has been fixed and as a result thereof a few more changes
were made in this second run.
2021-04-09 15:41:49 +02:00

155 lines
3.5 KiB
Perl
Executable File

#! /usr/bin/perl
# Copyright 2013-2021 The Mumble Developers. All rights reserved.
# Use of this source code is governed by a BSD-style license
# that can be found in the LICENSE file at the root of the
# Mumble source tree or at <https://www.mumble.info/LICENSE>.
use warnings;
use strict;
# If we're being run as a CGI in suexec, $HOME doesn't exist. Fake it.
my $home = (getpwuid($<))[7];
# This needs to be done before "use Net::DBus"
if (open(F, "$home/murmur/.dbus.sh")) {
while(<F>) {
chomp();
if ($_ =~ /^(.+?)\='(.+)';$/) {
$ENV{$1}=$2;
}
}
close(F);
}
use Net::DBus;
use CGI::Carp qw(fatalsToBrowser);
use HTML::Template;
my $tmpl_fname = $1 if ($0 =~ /(.+)\.([a-z]+)$/);
my $tmpl;
if (-f "$tmpl_fname.tmpl") {
$tmpl = HTML::Template->new(filename => "$tmpl_fname.tmpl");
} else {
$tmpl = HTML::Template->new(filehandle => *DATA);
}
my $bus;
my $service;
# First try the system bus
eval {
$bus=Net::DBus->system();
$service = $bus->get_service("net.sourceforge.mumble.murmur");
};
# If that failed, the session bus
if (! $service) {
eval {
$bus = Net::DBus->session();
$service = $bus->get_service("net.sourceforge.mumble.murmur");
}
}
die "Murmur service not found" if (! $service);
# Fetch handle to remote object
my $object = $service->get_object("/");
# Call a function on the murmur object
my $servers = $object->getBootedServers();
my $params = [];
foreach my $server (@{$servers}) {
my $name = $object->getConf($server, "registername");
my $servobj = $service->get_object("/$server");
my %users;
# First, get channel names
my $channels = $servobj->getChannels();
my %channels;
foreach my $c (@{$channels}) {
my @c = @{$c};
my $id = $c[0];
my $name = $c[1];
$channels{$id}=$name;
}
# Then, get and print the players
my $players = $servobj->getPlayers();
my $_total = 0;
foreach my $p (@{$players}) {
my @p = @{$p};
my $chanid = $p[6];
my $name = $p[8];
my $chan = $channels{$chanid};
$users{$chan} = [] unless $users{$chan};
push @{$users{$chan}}, $name;
$_total++;
}
my $_channels = [];
for my $c (sort keys %users) {
my $_users = [];
for my $u (sort @{$users{$c}}) {
push @{$_users}, {'user' => $u};
}
push @{$_channels}, {
'channel' => $c,
'users' => $_users
};
}
push @{$params}, {'server' => $server, 'name' => $name, 'total' => $_total, 'channels' => $_channels};
}
$tmpl->param("servers", $params);
print "Content-type: text/html;charset=utf8\r\n\r\n",
$tmpl->output;
__END__
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<HTML lang="ja">
<HEAD>
<Title>mumble server user list</title>
<STYLE TYPE="text/css">
<!--
body {
background-color: #ffffff;
color: #4b4b4b;
font-family: verdana, arial, sans-serif;
font-size: 13px;
margin: 10px 20px;
}
dl {
margin-left: 5px;
}
dt {
clear: both;
font-weight: bold;
padding-left: 5px;
border-left: #4b4b4b 5px solid
}
dd {
float: left;
margin-left: 5px;
margin-bottom: 5px;
margin-top: 2px;
}
-->
</STYLE>
</HEAD>
<BODY bgcolor="#ffffff" text="#4b4b4b" link="#3399ff" alink="#0099cc" vlink="#006666">
<TMPL_LOOP NAME="servers">
<H1>Server #<TMPL_VAR NAME="server"> <TMPL_VAR NAME="name"></H1>
total: <TMPL_VAR NAME="total">
<dl>
<TMPL_LOOP NAME="channels">
<dt><TMPL_VAR NAME="channel">
<dd>
<TMPL_LOOP NAME="users">
<TMPL_VAR NAME="user">,
</TMPL_LOOP>
</TMPL_LOOP>
</dl>
</TMPL_LOOP>
</BODY>
</HTML>