[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.64 by root, Thu Oct 25 09:01:23 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 ("c/who" => (join "\n\n", 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	if (my ($login) = $args =~ /(\S+)/) {
		59	if ($login eq $pl->name) {
		60	$pl->message ("Very funny, $login. Ha. Ha.", cf::NDI_REPLY);
		61	} elsif (cf::player::find_active $login) {
		62	$pl->message ("$login is right here on this server!", cf::NDI_REPLY);
		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_REPLY);
		70	} else {
		71	$pl->message ("No player named $login is known to me.", cf::NDI_REPLY);
		72	}
		73	} else {
		74	$pl->message ("Usage: seen <player>", cf::NDI_REPLY);
		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->send_msg ("c/body" => $reply, cf::NDI_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
		156	$ob->send_msg ("c/mapinfo" => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
		157	};
		158
		159	cf::register_command whereami => sub {
		160	my ($ob) = @_;
		161
		162	my $reg = $ob->contr->observe->region;
		163	$ob->send_msg ("c/mapinfo" => (sprintf "You are %s.\n%s", $reg->longname, $reg->msg), cf::NDI_REPLY \| cf::NDI_CLEAR);
		164	};
		165
		166	cf::register_command whereabouts => sub {
		167	my ($ob, $arg) = @_;
		168
		169	my %count;
		170
		171	for my $pl (cf::player::list) {
		172	++$count{$pl->ob->region->longname};
		173	}
		174
		175	my $msg = "In the world currently there are:\n\n"
		176	. join "", map "$count{$_} player(s) $_\n\n", sort keys %count;
		177
		178	$ob->send_msg ("c/mapinfo" => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
		179	};
		180
		181	cf::register_command hiscore => sub {
		182	my ($ob, $arg) = @_;
		183
		184	my $url = $cf::CFG{hiscore_url};
		185	$ob->send_msg (log => "See $url", cf::NDI_REPLY);
		186	};
		187
		188	sub _set_mode($$$@) {
		189	my ($name, $ob, $arg, $slot, @choices) = @_;
		190
		191	my $oldmode = $ob->contr->$slot;
		192
		193	return $ob->reply (undef, "$name is set to $choices[$oldmode]")
		194	unless $arg;
		195
		196	my ($idx) = grep $choices[$_] eq $arg, 0 .. $#choices
		197	or return $ob->reply (undef, "$name: Unknown options '$arg', valid options are @choices"), 1;
		198
		199	$ob->contr->$slot ($idx);
		200	$ob->reply (undef, "$name" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $choices[$ob->contr->$slot]);
		201	}
		202
		203	cf::register_command applymode => sub {
		204	my ($ob, $arg) = @_;
		205
		206	_set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
		207	};
		208
		209	cf::register_command petmode => sub {
		210	my ($ob, $arg) = @_;
		211
		212	_set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
		213	};
		214
		215	cf::register_command usekeys => sub {
		216	my ($ob, $arg) = @_;
		217
		218	_set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
		219	};
		220
		221	cf::register_command hintmode => sub {
		222	my ($ob, $arg) = @_;
		223
		224	_set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);
		225	};
		226
		227	cf::register_command afk => sub {
		228	my ($ob, $arg) = @_;
		229
		230	$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
		231	$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
		232	};
		233
		234	cf::register_command sound => sub {
		235	my ($ob, $arg) = @_;
		236
		237	$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
		238	$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
		239	};
		240
		241	cf::register_command brace => sub {
		242	my ($ob, $arg) = @_;
		243
		244	$ob->contr->braced ($ob->contr->braced ? 0 : 1);
		245	$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
		246	};
		247
		248	cf::register_command 'output-rate' => sub {
		249	my ($ob, $arg) = @_;
		250
		251	return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
		252	unless $arg > 0;
		253
		254	# minimum is 5k/s
		255	# maximum is 100k/s, this should be configurable
		256	$ob->contr->ns->max_rate ((List::Util::max 5000, List::Util::min 100000, $arg) * $cf::TICK);
		257	$ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
		258	};
		259
		260	cf::register_command 'output-count' => sub {
		261	my ($ob, $arg) = @_;
		262
		263	return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
		264	unless $arg > 0;
		265
		266	$arg = 4 if $arg < 4;
		267
		268	$ob->contr->outputs_count ($arg);
		269	$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
		270	};
		271
		272	cf::register_command 'output-sync' => sub {
		273	my ($ob, $arg) = @_;
		274
		275	return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
		276	unless length $arg;
		277
		278	$arg = 0.5 if $arg < 0.5;
		279
		280	$ob->contr->outputs_sync ($arg / $cf::TICK);
		281	$ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
		282	};
		283
		284	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
		285	# some other level (which may also be 0), this does not get echoed,
		286	# but it does get set.
		287	cf::register_command wimpy => sub {
		288	my ($ob, $arg) = @_;
		289
		290	my $wimpy = $ob->run_away;
		291	return $ob->reply (undef, "Your current wimpy level is $wimpy.")
		292	if $arg eq "";
		293
		294	return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
		295	if $arg =~ /^\d+$/ and $arg <= 100;
		296
		297	$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
		298	};
		299
		300	cf::register_command peaceful => sub {
		301	my ($ob, $arg) = @_;
		302
		303	$ob->reply (undef, "You cannot change your peaceful setting with this command."
		304	." Please speak to the priest in the temple of Gorokh"
		305	." if you want to become hostile or in temple of Valriel"
		306	." if you want to become peaceful again.");
		307
		308	#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
		309	#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
		310	};
6		311
7	sub rename_to($$$) {	312	sub rename_to($$$) {
8	my ($ob, $from, $to) = @_;	313	my ($ob, $from, $to) = @_;
9		314
10	$to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/	315	$to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
17		322
18	if (length $from) {	323	if (length $from) {
19	$item = $ob->find_best_object_match ($from)	324	$item = $ob->find_best_object_match ($from)
20	or return $ob->message ("rename: could not find a matching item to rename.");	325	or return $ob->message ("rename: could not find a matching item to rename.");
21	} else {	326	} else {
22	$item = $ob->find_marked_object ()	327	$item = $ob->find_marked_object
23	or return $ob->message ("rename: no from name and no marked item found to rename.");	328	or return $ob->message ("rename: no from name and no marked item found to rename.");
24	}	329	}
25		330
26	$item->custom_name (length $to ? $to : undef);	331	$item->custom_name (length $to ? $to : undef);
27		332
…		…
35		340
36	$ob->esrv_update_item (cf::UPD_NAME, $item);	341	$ob->esrv_update_item (cf::UPD_NAME, $item);
37		342
38	1	343	1
39	}	344	}
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		345
177	cf::register_command rename => sub {	346	cf::register_command rename => sub {
178	my ($ob, $arg) = @_;	347	my ($ob, $arg) = @_;
179		348
180	$ob->speed_left ($ob->speed_left - 0.25);	349	$ob->speed_left ($ob->speed_left - 0.25);
…		…
194	# does not unquote $1 or $3	363	# does not unquote $1 or $3
195	rename_to $ob, $2\|\|$1, $4\|\|$3;	364	rename_to $ob, $2\|\|$1, $4\|\|$3;
196	} else {	365	} else {
197	$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');	366	$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
198	}	367	}
199
200	1
201	};	368	};
202		369
203	cf::register_command uptime => sub {	370	cf::register_command uptime => sub {
204	my ($ob, $arg) = @_;	371	my ($ob, $arg) = @_;
205		372
206	my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;	373	my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
207	my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;	374	my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
208	$ob->reply (undef, "server started $startup, uptime ${runtime}\d");	375	$ob->send_msg ("c/uptime" => "server started $startup, uptime ${runtime}\d", cf::NDI_REPLY);
209
210	1
211	};	376	};
212		377
213	my %IN_MEMORY = (	378	my %IN_MEMORY = (
214	cf::MAP_IN_MEMORY => "I",	379	cf::MAP_IN_MEMORY => "I",
215	cf::MAP_SWAPPED => "S",	380	cf::MAP_SWAPPED => "S",
…		…
221		386
222	no re 'eval'; $arg = qr<$arg>;	387	no re 'eval'; $arg = qr<$arg>;
223		388
224	my $format = "%2s %1s %3s %5s %.60s\n";	389	my $format = "%2s %1s %3s %5s %.60s\n";
225		390
226	$ob->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK \| cf::NDI_UNIQUE);	391	$ob->send_msg ("c/mapinfo" => (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_REPLY \| cf::NDI_CLEAR);
227		392
228	for (sort keys %cf::MAP) {	393	for (sort keys %cf::MAP) {
229	my $map = $cf::MAP{$_}	394	my $map = $cf::MAP{$_}
230	or next;	395	or next;
231		396
…		…
233	next if $map->{deny_list};	398	next if $map->{deny_list};
234		399
235	my $svd = int $cf::RUNTIME - $map->{last_save};	400	my $svd = int $cf::RUNTIME - $map->{last_save};
236	$svd = "++" if $svd > 99;	401	$svd = "++" if $svd > 99;
237		402
238	$ob->reply (undef,	403	$ob->send_msg ("c/mapinfo" =>
239	(sprintf $format,	404	(sprintf $format,
240	(scalar $map->players),	405	(scalar $map->players),
241	$IN_MEMORY{$map->in_memory} \|\| "?",	406	$IN_MEMORY{$map->in_memory} \|\| "?",
242	$svd,	407	$svd,
243	(int $map->reset_at - $cf::RUNTIME),	408	(int $map->reset_at - $cf::RUNTIME),
244	$map->visible_name),	409	$map->visible_name)
245	cf::NDI_BLACK \| cf::NDI_UNIQUE);	410	);
246	}
247
248	1	411	}
249	};	412	};
250		413

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.64 by root, Thu Oct 25 09:01:23 2007 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.64 by root, Thu Oct 25 09:01:23 2007 UTC