[ViewVC] Diff of: cvs/deliantra/server/ext/commands.ext

Comparing deliantra/server/ext/commands.ext (file contents):
Revision 1.22 by pippijn, Fri Mar 2 10:44:56 2007 UTC vs.
Revision 1.76 by root, Mon Apr 12 05:22:37 2010 UTC

…		…
1	#! perl	1	#! perl # mandatory depends=irc
2		2
3	use POSIX ();	3	use POSIX ();
4		4
5	# miscellaneous commands	5	# miscellaneous commands
		6
		7	sub who_listing(;$$) {
		8	my ($privileged, $select) = @_;
		9
		10	my ($numwiz, $numafk) = (0, 0);
		11	my @pl;
		12
		13	foreach my $pl (cf::player::list) {
		14	my $ns = $pl->ns or next;
		15	my $ob = $pl->ob;
		16
		17	next unless $ob->map
		18	&& ($privileged \|\| !$pl->hidden);
		19
		20	$numwiz++ if $ob->flag (cf::FLAG_WIZ);
		21	$numafk++ if $ns->afk;
		22
		23	push @pl, $pl;
		24	}
		25
		26	(
		27	"Total Players in The World. (" . (scalar @pl) . ") -- WIZ($numwiz) AFK($numafk) BOT(0)",
		28	(grep /$select/,
		29	map {
		30	my ($pl, $ob, $ns) = ($_, $_->ob, $_->ns);
		31
		32	"* " . $ob->name . "/" . $ob->level . " " . (length $pl->own_title ? $pl->own_title : "the " . $pl->title)
		33	. ($pl->gender ? " [f]" : " [m]")
		34	. ($pl->peaceful ? " [peaceful]" : " [HOSTILE]")
		35	. ($ns->afk ? " [AFK]" : "")
		36	. ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "")
		37	. " [" . $pl->ns->{who_version} . "]"
		38	. " [" . ($pl->peaceful \|\| $privileged ? $ob->map->visible_name : $ob->region->name) . "]"
		39	. (sprintf " [rtt %.3fs]", $pl->ns->tcpi_rtt * 1e-6)
		40	. ($privileged ? " " . $pl->ns->host : "")
		41	} sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl
		42	),
		43	eval { "* IRC: " . join ", ", ext::irc::users },
		44	)
		45	}
		46
		47	cf::register_command who => sub {
		48	my ($ob, $arg) = @_;
		49
		50	$ob->speed_left ($ob->speed_left - 4);
		51
		52	$ob->send_msg ("c/who" => (join "\r", who_listing $ob->may ("extended_who"), $arg), cf::NDI_DK_ORANGE \| cf::NDI_REPLY \| cf::NDI_CLEAR \| cf::NDI_DEF);
		53	};
		54
		55	cf::register_command seen => sub {
		56	my ($pl, $args) = @_;
		57
		58	cf::async {
		59	if (my ($login) = $args =~ /(\S+)/) {
		60	if ($login eq $pl->name) {
		61	$pl->message ("Very funny, $login. Ha. Ha.", cf::NDI_REPLY);
		62	} elsif (cf::player::find_active $login) {
		63	$pl->message ("$login is right here on this server!", cf::NDI_REPLY);
		64	} elsif (cf::player::exists $login
		65	and stat cf::player::path $login) {
		66	my $time = (stat _)[9];
		67
		68	$pl->message ("$login was last seen here "
		69	. (POSIX::strftime "%Y-%m-%d %H:%M:%S +0000", gmtime $time)
		70	. " which was " . (int +(time - $time) / 3600) . " hours ago.", cf::NDI_REPLY);
		71	} else {
		72	$pl->message ("No player named $login is known to me.", cf::NDI_REPLY);
		73	}
		74	} else {
		75	$pl->message ("Usage: seen <player>", cf::NDI_REPLY);
		76	}
		77	};
		78	};
		79
		80	cf::register_command body => sub {
		81	my ($ob) = @_;
		82
		83	my $observe = $ob->contr->observe;
		84
		85	# Too hard to try and make a header that lines everything up, so just
		86	# give a description. (comment from C++)
		87	my $reply =
		88	"The first column is the name of the body location.\r"
		89	. "The second column is how many of those locations your body has.\r"
		90	. "The third column is how many slots in that location are available.\r"
		91	. "The last column shows the items currently using the slot\n\n";
		92
		93	# first process all applied items and hash them into their slots
		94	my @slot;
		95
		96	for my $item (grep $_->flag (cf::FLAG_APPLIED), $observe->inv) {
		97	$item->slot_info ($_)
		98	and push @{ $slot[$_] }, $item
		99	for 0 .. cf::NUM_BODY_LOCATIONS-1;
		100	}
		101
		102	$reply .= sprintf " %-20s %3s %5s %s\n", "Location", "You", "Avail", "What";
		103	for (0 .. cf::NUM_BODY_LOCATIONS - 1) {
		104	my $msg = cf::object::slot_nonuse_name $_;
		105	$msg =~ s/^.*? a //;
		106	$reply .= sprintf " %-20s %3d %5d %s\n",
		107	$msg,
		108	$observe->slot_info ($_),
		109	$observe->slot_used ($_),
		110	join ", ", map $_->query_short_name, @{ $slot[$_] }
		111	if $observe->slot_info ($_) \|\| $observe->slot_used ($_);
		112	}
		113
		114	$reply .= "You are not allowed to wear armor\r"
		115	unless $observe->flag (cf::FLAG_USE_ARMOUR);
		116	$reply .= "You are not allowed to use weapons\r"
		117	unless $observe->flag (cf::FLAG_USE_WEAPON);
		118
		119	$ob->send_msg ("c/body" => $reply, cf::NDI_REPLY \| cf::NDI_CLEAR);
		120	};
		121
		122	#cf::register_command mark => sub {
		123	# my ($pl, $arg) = @_;
		124	#
		125	# if (length $arg) {
		126	# my $ob = $pl->find_best_object_match ($arg);
		127	#
		128	# return $pl->reply (undef, "Could not find an object that matches $arg")
		129	# unless $ob;
		130	#
		131	# $pl->contr->mark ($ob);
		132	# $pl->reply (undef, (sprintf "Marked item %s", $ob->name, $ob->title));
		133	# } else {
		134	# my $ob = $pl->find_marked_object;
		135	#
		136	# $pl->reply (undef, $ob
		137	# ? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
		138	# : "You have no marked object.");
		139	# }
		140	#};
		141
		142	cf::register_command mapinfo => sub {
		143	my ($ob) = @_;
		144
		145	my $observe = $ob->contr->observe;
		146
		147	my $map = $observe->map
		148	or return;
		149
		150	my $msg = sprintf "%s (%s)\r%s", $map->name, $map->path, $observe->region->longname;
		151	$msg .= sprintf "\rplayers: %d difficulty: %d size: %d start: %dx%d timeout: %d",
		152	(scalar $map->players), $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout
		153	if $ob->flag (cf::FLAG_WIZ);
		154
		155	$ob->send_msg ("c/mapinfo" => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
		156	};
		157
		158	cf::register_command whereami => sub {
		159	my ($ob) = @_;
		160
		161	my $reg = $ob->contr->observe->region;
		162	$ob->send_msg ("c/who" => (sprintf "You are %s.\n\n%s", $reg->longname, $reg->msg), cf::NDI_REPLY \| cf::NDI_CLEAR);
		163	};
		164
		165	cf::register_command whereabouts => sub {
		166	my ($ob, $arg) = @_;
		167
		168	my %count;
		169
		170	for my $pl (cf::player::list) {
		171	++$count{$pl->ob->region->longname};
		172	}
		173
		174	my $msg = "T<In the world currently there are:>\n\n"
		175	. join "", map { sprintf " C<%3d >player(s) %s\r", $count{$_}, $_ } sort keys %count;
		176
		177	$ob->send_msg ("c/who" => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
		178	};
		179
		180	cf::register_command hiscore => sub {
		181	my ($ob, $arg) = @_;
		182
		183	my $url = $cf::CFG{hiscore_url};
		184	$ob->send_msg (log => "See $url", cf::NDI_REPLY);
		185	};
		186
		187	sub _set_mode($$$@) {
		188	my ($name, $ob, $arg, $slot, @choices) = @_;
		189
		190	my $oldmode = $ob->contr->$slot;
		191
		192	return $ob->reply (undef, "$name is set to $choices[$oldmode]")
		193	unless $arg;
		194
		195	my ($idx) = grep $choices[$_] eq $arg, 0 .. $#choices
		196	or return $ob->reply (undef, "$name: Unknown options '$arg', valid options are @choices"), 1;
		197
		198	$ob->contr->$slot ($idx);
		199	$ob->reply (undef, "$name" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $choices[$ob->contr->$slot]);
		200	}
		201
		202	cf::register_command applymode => sub {
		203	my ($ob, $arg) = @_;
		204
		205	_set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
		206	};
		207
		208	cf::register_command petmode => sub {
		209	my ($ob, $arg) = @_;
		210
		211	_set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
		212	};
		213
		214	cf::register_command usekeys => sub {
		215	my ($ob, $arg) = @_;
		216
		217	_set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
		218	};
		219
		220	cf::register_command hintmode => sub {
		221	my ($ob, $arg) = @_;
		222
		223	_set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);
		224	};
		225
		226	cf::register_command afk => sub {
		227	my ($ob, $arg) = @_;
		228
		229	$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
		230	$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
		231	};
		232
		233	cf::register_command sound => sub {
		234	my ($ob, $arg) = @_;
		235
		236	$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
		237	$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
		238	};
		239
		240	cf::register_command brace => sub {
		241	my ($ob, $arg) = @_;
		242
		243	$ob->contr->braced ($ob->contr->braced ? 0 : 1);
		244	$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
		245	};
		246
		247	cf::register_command 'output-rate' => sub {
		248	my ($ob, $arg) = @_;
		249
		250	return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
		251	unless $arg > 0;
		252
		253	$ob->contr->ns->max_rate ((cf::clamp $arg, $OUTPUT_RATE_MIN, $OUTPUT_RATE_MAX) * $TICK);
		254	$ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $TICK);
		255	};
		256
		257	cf::register_command 'output-count' => sub {
		258	my ($ob, $arg) = @_;
		259
		260	return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
		261	unless $arg > 0;
		262
		263	$arg = 4 if $arg < 4;
		264
		265	$ob->contr->outputs_count ($arg);
		266	$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
		267	};
		268
		269	cf::register_command 'output-sync' => sub {
		270	my ($ob, $arg) = @_;
		271
		272	return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
		273	unless length $arg;
		274
		275	$arg = 0.5 if $arg < 0.5;
		276
		277	$ob->contr->outputs_sync ($arg / $cf::TICK);
		278	$ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
		279	};
		280
		281	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
		282	# some other level (which may also be 0), this does not get echoed,
		283	# but it does get set.
		284	cf::register_command wimpy => sub {
		285	my ($ob, $arg) = @_;
		286
		287	my $wimpy = $ob->run_away;
		288	return $ob->reply (undef, "Your current wimpy level is $wimpy.")
		289	if $arg eq "";
		290
		291	return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
		292	if $arg =~ /^\d+$/ and $arg <= 100;
		293
		294	$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
		295	};
		296
		297	cf::register_command peaceful => sub {
		298	my ($ob, $arg) = @_;
		299
		300	$ob->reply (undef, "You cannot change your peaceful setting with this command."
		301	." Please speak to the priest in the temple of Gorokh"
		302	." if you want to become hostile or in temple of Valriel"
		303	." if you want to become peaceful again.");
		304
		305	#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
		306	#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
		307	};
6		308
7	sub rename_to($$$) {	309	sub rename_to($$$) {
8	my ($ob, $from, $to) = @_;	310	my ($ob, $from, $to) = @_;
9		311
10	$to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/	312	$to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
17		319
18	if (length $from) {	320	if (length $from) {
19	$item = $ob->find_best_object_match ($from)	321	$item = $ob->find_best_object_match ($from)
20	or return $ob->message ("rename: could not find a matching item to rename.");	322	or return $ob->message ("rename: could not find a matching item to rename.");
21	} else {	323	} else {
22	$item = $ob->find_marked_object ()	324	$item = $ob->find_marked_object
23	or return $ob->message ("rename: no from name and no marked item found to rename.");	325	or return $ob->message ("rename: no from name and no marked item found to rename.");
24	}	326	}
25		327
26	$item->custom_name (length $to ? $to : undef);	328	$item->custom_name (length $to ? $to : undef);
27		329
…		…
35		337
36	$ob->esrv_update_item (cf::UPD_NAME, $item);	338	$ob->esrv_update_item (cf::UPD_NAME, $item);
37		339
38	1	340	1
39	}	341	}
40
41	sub ext::schmorp_irc::users; # HACK: TODO: replace by signal
42
43	sub who_listing(;$) {
44	my ($privileged) = @_;
45
46	my ($numwiz, $numafk) = (0, 0);
47	my @pl;
48
49	foreach my $pl (cf::player::list) {
50	my $ns = $pl->ns or next;
51	my $ob = $pl->ob;
52
53	next unless $ob->map
54	&& ($privileged \|\| !$pl->hidden);
55
56	$numwiz++ if $ob->flag (cf::FLAG_WIZ);
57	$numafk++ if $ns->afk;
58
59	push @pl, $pl;
60	}
61
62	(
63	"Total Players in The World. (" . (scalar @pl) . ") -- WIZ($numwiz) AFK($numafk) BOT(0)",
64	(
65	map {
66	my ($pl, $ob, $ns) = ($_, $_->ob, $_->ns);
67
68	"* " . $ob->name . "/" . $ob->level . " " . (length $pl->own_title ? $pl->own_title : "the " . $pl->title)
69	. ($pl->peaceful ? " [peaceful]" : " [HOSTILE]")
70	. ($ns->afk ? " [AFK]" : "")
71	. ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "")
72	. " [" . $pl->ns->version . "]"
73	. " [" . ($pl->peaceful \|\| $privileged ? $ob->map->visible_name : $ob->region->name) . "]"
74	. (sprintf " [rtt %.3fs]", $pl->ns->rtt * 1e-6)
75	. ($privileged ? " " . $pl->ns->host : "")
76	} sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl
77	),
78	eval { "* IRC: " . join ", ", ext::schmorp_irc::users },
79	)
80	}
81
82	cf::register_command who => sub {
83	my ($ob, $arg) = @_;
84
85	$ob->speed_left ($ob->speed_left - 0.25);
86
87	$ob->reply (undef, (join "\n", who_listing $ob->may ("extended_who")), cf::NDI_UNIQUE \| cf::NDI_DK_ORANGE);
88
89	1
90	};
91
92	cf::register_command usekeys => sub {
93	my ($ob, $arg) = @_;
94	my @types = ("inventory", "keyrings", "containers");
95	my $mapping = {
96	inventory => 1,
97	keyrings => 2,
98	containers => 3,
99	};
100
101	my $oldtype = $ob->contr->usekeys;
102	my $oldtype_name = $types[$oldtype];
103
104	return $ob->reply (undef, "usekeys is set to $oldtype_name")
105	unless $arg;
106
107	return $ob->reply (undef, "usekeys: Unknown options '$arg', valid options are inventory, keyrings, containers")
108	unless $mapping->{$arg};
109
110	$ob->contr->usekeys ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
111	# but $arg would be 0 if a user enters an incorrect value
112	$ob->reply (undef, "usekeys" . ($oldtype == $ob->contr->usekeys ? "" : " now") . " set to " . $types[$ob->contr->usekeys]);
113
114	1
115	};
116
117	cf::register_command afk => sub {
118	my ($ob, $arg) = @_;
119
120	$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
121	$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
122
123	1
124	};
125
126	cf::register_command sound => sub {
127	my ($ob, $arg) = @_;
128
129	$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
130	$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
131
132	1
133	};
134
135	cf::register_command brace => sub {
136	my ($ob, $arg) = @_;
137
138	$ob->contr->braced ($ob->contr->braced ? 0 : 1);
139	$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
140
141	1
142	};
143
144	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
145	# some other level (which may also be 0), this does not get echoed,
146	# but it does get set.
147	cf::register_command wimpy => sub {
148	my ($ob, $arg) = @_;
149
150	my $wimpy = $ob->run_away;
151	return $ob->reply (undef, "Your current wimpy level is $wimpy.")
152	if $arg eq "";
153
154	return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
155	if $arg =~ /^\d+$/ and $arg <= 100;
156
157	$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
158
159	1
160	};
161
162	cf::register_command peaceful => sub {
163	my ($ob, $arg) = @_;
164
165	$ob->reply (undef, "You cannot change your peaceful setting with this command."
166	." Please speak to the priest in the temple of Gorokh"
167	." if you want to become hostile or in temple of Valriel"
168	." if you want to become peaceful again.");
169
170	#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
171	#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
172
173	1
174	};
175
176		342
177	cf::register_command rename => sub {	343	cf::register_command rename => sub {
178	my ($ob, $arg) = @_;	344	my ($ob, $arg) = @_;
179		345
180	$ob->speed_left ($ob->speed_left - 0.25);	346	$ob->speed_left ($ob->speed_left - 0.25);
…		…
194	# does not unquote $1 or $3	360	# does not unquote $1 or $3
195	rename_to $ob, $2\|\|$1, $4\|\|$3;	361	rename_to $ob, $2\|\|$1, $4\|\|$3;
196	} else {	362	} else {
197	$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');	363	$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
198	}	364	}
199
200	1
201	};	365	};
202		366
203	cf::register_command uptime => sub {	367	cf::register_command uptime => sub {
204	my ($ob, $arg) = @_;	368	my ($ob, $arg) = @_;
205		369
206	my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;	370	my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
207	my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;	371	my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
208	$ob->reply (undef, "server started $startup, uptime ${runtime}\d");	372	$ob->send_msg ("c/uptime" => "server started $startup, uptime ${runtime}\d", cf::NDI_REPLY \| cf::NDI_CLEAR);
209
210	1
211	};	373	};
212		374
213	my %IN_MEMORY = (	375	my %IN_MEMORY = (
214	cf::MAP_IN_MEMORY => "I",	376	cf::MAP_ACTIVE => "I",
215	cf::MAP_SWAPPED => "S",	377	cf::MAP_SWAPPED => "S",
216	cf::MAP_LOADING => "L",	378	cf::MAP_LOADING => "L",
217	);	379	);
218		380
219	cf::register_command maps => sub {	381	cf::register_command maps => sub {
220	my ($ob, $arg) = @_;	382	my ($ob, $arg) = @_;
221		383
222	no re 'eval'; $arg = qr<$arg>;	384	no re 'eval'; $arg = qr<$arg>;
223		385
224	my $format = "%2s %1s %3s %5s %.60s\n";	386	my $format = " %2s %1s %3s %5s %.60s\n";
225		387
226	$ob->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK \| cf::NDI_UNIQUE);	388	my $msg = "\n" . sprintf $format, "Pl", "I", "Svd", "Reset", "Name";
227		389
228	for (sort keys %cf::MAP) {	390	for (sort keys %cf::MAP) {
229	my $map = $cf::MAP{$_}	391	my $map = $cf::MAP{$_}
230	or next;	392	or next;
231		393
…		…
233	next if $map->{deny_list};	395	next if $map->{deny_list};
234		396
235	my $svd = int $cf::RUNTIME - $map->{last_save};	397	my $svd = int $cf::RUNTIME - $map->{last_save};
236	$svd = "++" if $svd > 99;	398	$svd = "++" if $svd > 99;
237		399
238	$ob->reply (undef,	400	$msg .= sprintf $format,
239	(sprintf $format,
240	(scalar $map->players),	401	(scalar $map->players),
241	$IN_MEMORY{$map->in_memory} \|\| "?",	402	$IN_MEMORY{$map->in_memory} \|\| "?",
242	$svd,	403	$svd,
243	(int $map->reset_at - $cf::RUNTIME),	404	(int $map->reset_at - $cf::RUNTIME),
244	$map->visible_name),	405	$map->visible_name;
245	cf::NDI_BLACK \| cf::NDI_UNIQUE);
246	}
247
248	1	406	}
249	};
250		407
		408	$ob->send_msg ("c/mapinfo" => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
		409	};
		410

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing deliantra/server/ext/commands.ext (file contents): Revision 1.22 by pippijn, Fri Mar 2 10:44:56 2007 UTC vs. Revision 1.76 by root, Mon Apr 12 05:22:37 2010 UTC

Diff Legend

Comparing deliantra/server/ext/commands.ext (file contents):
Revision 1.22 by pippijn, Fri Mar 2 10:44:56 2007 UTC vs.
Revision 1.76 by root, Mon Apr 12 05:22:37 2010 UTC