1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
#! /usr/bin/perl
# Copyright 2013-2022 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>
|
