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

Comparing deliantra/server/ext/commands.ext (file contents):
Revision 1.23 by pippijn, Fri Mar 2 10:54:59 2007 UTC vs.
Revision 1.60 by root, Fri Aug 10 05:38:16 2007 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->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 (log => (join "\n\n", who_listing $ob->may ("extended_who"), $arg), cf::NDI_DK_ORANGE \| cf::NDI_REPLY);
		53	};
		54
		55	cf::register_command seen => sub {
		56	my ($pl, $args) = @_;
		57
		58	if (my ($login) = $args =~ /(\S+)/) {
		59	if ($login eq $pl->name) {
		60	$pl->message ("Very funny, $login. Ha. Ha.", cf::NDI_UNIQUE);
		61	} elsif (cf::player::find_active $login) {
		62	$pl->message ("$login is right here on this server!", cf::NDI_UNIQUE);
		63	} elsif (cf::player::exists $login
		64	and stat cf::player::path $login) {
		65	my $time = (stat _)[9];
		66
		67	$pl->message ("$login was last seen here "
		68	. (POSIX::strftime "%Y-%m-%d %H:%M:%S +0000", gmtime $time)
		69	. " which was " . (int +(time - $time) / 3600) . " hours ago.", cf::NDI_UNIQUE);
		70	} else {
		71	$pl->message ("No player named $login is known to me.", cf::NDI_UNIQUE);
		72	}
		73	} else {
		74	$pl->message ("Usage: seen <player>", cf::NDI_UNIQUE);
		75	}
		76	};
		77
		78	cf::register_command body => sub {
		79	my ($ob) = @_;
		80
		81	# Too hard to try and make a header that lines everything up, so just
		82	# give a description. (comment from C++)
		83	my $reply =
		84	"The first column is the name of the body location.\n\n"
		85	. "The second column is how many of those locations your body has.\n\n"
		86	. "The third column is how many slots in that location are available.\n\n";
		87
		88	$reply .= sprintf " %-20s %3s %5s\n", "Location", "You", "Avail";
		89	for (0 .. cf::NUM_BODY_LOCATIONS - 1) {
		90	my $msg = cf::object::slot_nonuse_name $_;
		91	$msg =~ s/^.*? a //;
		92	$reply .= sprintf " %-20s %3d %5d\n", $msg, $ob->slot_info ($_), $ob->slot_used ($_)
		93	if $ob->slot_info ($_) or $ob->slot_used ($_);
		94	}
		95
		96	$reply .= "You are not allowed to wear armor\n\n"
		97	unless $ob->flag (cf::FLAG_USE_ARMOUR);
		98	$reply .= "You are not allowed to use weapons\n\n"
		99	unless $ob->flag (cf::FLAG_USE_WEAPON);
		100
		101	$ob->reply (undef, $reply);
		102	};
		103
		104	cf::register_command mark => sub {
		105	my ($pl, $arg) = @_;
		106
		107	if (length $arg) {
		108	my $ob = $pl->find_best_object_match ($arg);
		109
		110	return $pl->reply (undef, "Could not find an object that matches $arg")
		111	unless $ob;
		112
		113	$pl->contr->mark ($ob);
		114	$pl->reply (undef, (sprintf "Marked item %s", $ob->name, $ob->title));
		115	} else {
		116	my $ob = $pl->find_marked_object;
		117
		118	$pl->reply (undef, $ob
		119	? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
		120	: "You have no marked object.");
		121	}
		122	};
		123
		124	for my $cmd ("run", "fire") {
		125	my $oncmd = "${cmd}_on";
		126	cf::register_command $cmd => sub {
		127	my ($ob, $arg) = @_;
		128
		129	$ob->reply (undef, "Can't $cmd into a non adjacent square.")
		130	if $arg < 0 or $arg >= 9;
		131
		132	$ob->contr->$oncmd (1);
		133	$ob->move_player ($arg);
		134	};
		135
		136	cf::register_command "${cmd}_stop" => sub {
		137	my ($ob) = @_;
		138
		139	$ob->contr->$oncmd (0);
		140	};
		141	}
		142
		143	cf::register_command mapinfo => sub {
		144	my ($ob) = @_;
		145
		146	my $observe = $ob->contr->observe;
		147
		148	my $map = $observe->map
		149	or return;
		150
		151	my $msg = sprintf "%s (%s) %s", $map->name, $map->path, $observe->region->longname;
		152	$msg .= sprintf "\n\nplayers: %d difficulty: %d size: %d start: %dx%d timeout: %d",
		153	(scalar $map->players), $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout
		154	if $ob->flag (cf::FLAG_WIZ);
		155	$ob->send_msg (log => $msg, cf::NDI_REPLY);
		156	};
		157
		158	cf::register_command whereami => sub {
		159	my ($ob) = @_;
		160
		161	my $reg = $ob->contr->observe->region;
		162	$ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg));
		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 = "In the world currently there are:\n\n"
		175	. join "", map "$count{$_} player(s) in $_\n\n", sort keys %count;
		176
		177	$ob->send_msg (log => $msg, cf::NDI_REPLY);
		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	# minimum is 5k/s
		254	# maximum is 100k/s, this should be configurable
		255	$ob->contr->ns->max_rate ((List::Util::max 5000, List::Util::min 100000, $arg) * $cf::TICK);
		256	$ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
		257	};
		258
		259	cf::register_command 'output-count' => sub {
		260	my ($ob, $arg) = @_;
		261
		262	return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
		263	unless $arg > 0;
		264
		265	$arg = 4 if $arg < 4;
		266
		267	$ob->contr->outputs_count ($arg);
		268	$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
		269	};
		270
		271	cf::register_command 'output-sync' => sub {
		272	my ($ob, $arg) = @_;
		273
		274	return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
		275	unless length $arg;
		276
		277	$arg = 0.5 if $arg < 0.5;
		278
		279	$ob->contr->outputs_sync ($arg / $cf::TICK);
		280	$ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
		281	};
		282
		283	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
		284	# some other level (which may also be 0), this does not get echoed,
		285	# but it does get set.
		286	cf::register_command wimpy => sub {
		287	my ($ob, $arg) = @_;
		288
		289	my $wimpy = $ob->run_away;
		290	return $ob->reply (undef, "Your current wimpy level is $wimpy.")
		291	if $arg eq "";
		292
		293	return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
		294	if $arg =~ /^\d+$/ and $arg <= 100;
		295
		296	$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
		297	};
		298
		299	cf::register_command peaceful => sub {
		300	my ($ob, $arg) = @_;
		301
		302	$ob->reply (undef, "You cannot change your peaceful setting with this command."
		303	." Please speak to the priest in the temple of Gorokh"
		304	." if you want to become hostile or in temple of Valriel"
		305	." if you want to become peaceful again.");
		306
		307	#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
		308	#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
		309	};
6		310
7	sub rename_to($$$) {	311	sub rename_to($$$) {
8	my ($ob, $from, $to) = @_;	312	my ($ob, $from, $to) = @_;
9		313
10	$to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/	314	$to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
17		321
18	if (length $from) {	322	if (length $from) {
19	$item = $ob->find_best_object_match ($from)	323	$item = $ob->find_best_object_match ($from)
20	or return $ob->message ("rename: could not find a matching item to rename.");	324	or return $ob->message ("rename: could not find a matching item to rename.");
21	} else {	325	} else {
22	$item = $ob->find_marked_object ()	326	$item = $ob->find_marked_object
23	or return $ob->message ("rename: no from name and no marked item found to rename.");	327	or return $ob->message ("rename: no from name and no marked item found to rename.");
24	}	328	}
25		329
26	$item->custom_name (length $to ? $to : undef);	330	$item->custom_name (length $to ? $to : undef);
27		331
…		…
35		339
36	$ob->esrv_update_item (cf::UPD_NAME, $item);	340	$ob->esrv_update_item (cf::UPD_NAME, $item);
37		341
38	1	342	1
39	}	343	}
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 applymode => sub {
93	my ($ob, $arg) = @_;
94	my @types = ("nochoice", "never", "always");
95	my $mapping = {
96	nochoice => 1,
97	never => 2,
98	always => 3,
99	};
100
101	my $oldmode = $ob->contr->unapply;
102	my $oldmode_name = $types[$oldmode];
103
104	return $ob->reply (undef, "applymode is set to $oldmode_name")
105	unless $arg;
106
107	return $ob->reply (undef, "applymode: Unknown options '$arg', valid options are @types")
108	unless $mapping->{$arg};
109
110	$ob->contr->unapply ($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, "applymode" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $types[$ob->contr->unapply]);
113
114	1
115	};
116
117	cf::register_command petmode => sub {
118	my ($ob, $arg) = @_;
119	my @types = ("normal", "sad", "defend", "arena");
120	my $mapping = {
121	normal => 1,
122	sad => 2,
123	defend => 3,
124	arena => 4,
125	};
126
127	my $oldtype = $ob->contr->petmode;
128	my $oldtype_name = $types[$oldtype];
129
130	return $ob->reply (undef, "petmode is set to $oldtype_name")
131	unless $arg;
132
133	return $ob->reply (undef, "petmode: Unknown options '$arg', valid options are @types")
134	unless $mapping->{$arg};
135
136	$ob->contr->petmode ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
137	# but $arg would be 0 if a user enters an incorrect value
138	$ob->reply (undef, "petmode" . ($oldtype == $ob->contr->petmode ? "" : " now") . " set to " . $types[$ob->contr->petmode]);
139
140	1
141	};
142
143	cf::register_command usekeys => sub {
144	my ($ob, $arg) = @_;
145	my @types = ("inventory", "keyrings", "containers");
146	my $mapping = {
147	inventory => 1,
148	keyrings => 2,
149	containers => 3,
150	};
151
152	my $oldtype = $ob->contr->usekeys;
153	my $oldtype_name = $types[$oldtype];
154
155	return $ob->reply (undef, "usekeys is set to $oldtype_name")
156	unless $arg;
157
158	return $ob->reply (undef, "usekeys: Unknown options '$arg', valid options are @types")
159	unless $mapping->{$arg};
160
161	$ob->contr->usekeys ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
162	# but $arg would be 0 if a user enters an incorrect value
163	$ob->reply (undef, "usekeys" . ($oldtype == $ob->contr->usekeys ? "" : " now") . " set to " . $types[$ob->contr->usekeys]);
164
165	1
166	};
167
168	cf::register_command afk => sub {
169	my ($ob, $arg) = @_;
170
171	$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
172	$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
173
174	1
175	};
176
177	cf::register_command sound => sub {
178	my ($ob, $arg) = @_;
179
180	$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
181	$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
182
183	1
184	};
185
186	cf::register_command brace => sub {
187	my ($ob, $arg) = @_;
188
189	$ob->contr->braced ($ob->contr->braced ? 0 : 1);
190	$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
191
192	1
193	};
194
195	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
196	# some other level (which may also be 0), this does not get echoed,
197	# but it does get set.
198	cf::register_command wimpy => sub {
199	my ($ob, $arg) = @_;
200
201	my $wimpy = $ob->run_away;
202	return $ob->reply (undef, "Your current wimpy level is $wimpy.")
203	if $arg eq "";
204
205	return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
206	if $arg =~ /^\d+$/ and $arg <= 100;
207
208	$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
209
210	1
211	};
212
213	cf::register_command peaceful => sub {
214	my ($ob, $arg) = @_;
215
216	$ob->reply (undef, "You cannot change your peaceful setting with this command."
217	." Please speak to the priest in the temple of Gorokh"
218	." if you want to become hostile or in temple of Valriel"
219	." if you want to become peaceful again.");
220
221	#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
222	#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
223
224	1
225	};
226
227		344
228	cf::register_command rename => sub {	345	cf::register_command rename => sub {
229	my ($ob, $arg) = @_;	346	my ($ob, $arg) = @_;
230		347
231	$ob->speed_left ($ob->speed_left - 0.25);	348	$ob->speed_left ($ob->speed_left - 0.25);
…		…
245	# does not unquote $1 or $3	362	# does not unquote $1 or $3
246	rename_to $ob, $2\|\|$1, $4\|\|$3;	363	rename_to $ob, $2\|\|$1, $4\|\|$3;
247	} else {	364	} else {
248	$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');	365	$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
249	}	366	}
250
251	1
252	};	367	};
253		368
254	cf::register_command uptime => sub {	369	cf::register_command uptime => sub {
255	my ($ob, $arg) = @_;	370	my ($ob, $arg) = @_;
256		371
257	my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;	372	my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
258	my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;	373	my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
259	$ob->reply (undef, "server started $startup, uptime ${runtime}\d");	374	$ob->reply (undef, "server started $startup, uptime ${runtime}\d");
260
261	1
262	};	375	};
263		376
264	my %IN_MEMORY = (	377	my %IN_MEMORY = (
265	cf::MAP_IN_MEMORY => "I",	378	cf::MAP_IN_MEMORY => "I",
266	cf::MAP_SWAPPED => "S",	379	cf::MAP_SWAPPED => "S",
…		…
293	$svd,	406	$svd,
294	(int $map->reset_at - $cf::RUNTIME),	407	(int $map->reset_at - $cf::RUNTIME),
295	$map->visible_name),	408	$map->visible_name),
296	cf::NDI_BLACK \| cf::NDI_UNIQUE);	409	cf::NDI_BLACK \| cf::NDI_UNIQUE);
297	}	410	}
298
299	1
300	};	411	};
301		412

Diff Legend

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

Comparing deliantra/server/ext/commands.ext (file contents): Revision 1.23 by pippijn, Fri Mar 2 10:54:59 2007 UTC vs. Revision 1.60 by root, Fri Aug 10 05:38:16 2007 UTC

Diff Legend

Comparing deliantra/server/ext/commands.ext (file contents):
Revision 1.23 by pippijn, Fri Mar 2 10:54:59 2007 UTC vs.
Revision 1.60 by root, Fri Aug 10 05:38:16 2007 UTC