ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/ext/commands.ext
(Generate patch)

Comparing deliantra/server/ext/commands.ext (file contents):
Revision 1.57 by root, Sat Jul 28 00:15:03 2007 UTC vs.
Revision 1.70 by root, Mon Sep 22 01:33:09 2008 UTC

1#! perl # mandatory depends=irc 1#! perl # mandatory depends=irc
2 2
3use POSIX (); 3use POSIX ();
4 4
5# miscellaneous commands 5# miscellaneous commands
6
7sub rename_to($$$) {
8 my ($ob, $from, $to) = @_;
9
10 $to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
11 or return $ob->message ("rename: name must consist only of letters, digits, spaces and a few other things.");
12
13 127 >= length $to
14 or return $ob->message ("rename: new name must be <= 127 characters.");
15
16 my $item;
17
18 if (length $from) {
19 $item = $ob->find_best_object_match ($from)
20 or return $ob->message ("rename: could not find a matching item to rename.");
21 } else {
22 $item = $ob->find_marked_object
23 or return $ob->message ("rename: no from name and no marked item found to rename.");
24 }
25
26 $item->custom_name (length $to ? $to : undef);
27
28 if (length $to) {
29 $item->custom_name ($to);
30 $ob->message ("Your " . $item->base_name . " will now be called $to.");
31 } else {
32 $item->custom_name (undef);
33 $ob->message ("You stop calling your " . $item->base_name . " with weird names.");
34 }
35
36 $ob->esrv_update_item (cf::UPD_NAME, $item);
37
38 1
39}
40 6
41sub who_listing(;$$) { 7sub who_listing(;$$) {
42 my ($privileged, $select) = @_; 8 my ($privileged, $select) = @_;
43 9
44 my ($numwiz, $numafk) = (0, 0); 10 my ($numwiz, $numafk) = (0, 0);
… …
81cf::register_command who => sub { 47cf::register_command who => sub {
82 my ($ob, $arg) = @_; 48 my ($ob, $arg) = @_;
83 49
84 $ob->speed_left ($ob->speed_left - 4); 50 $ob->speed_left ($ob->speed_left - 4);
85 51
86 $ob->reply (undef, (join "\n", who_listing $ob->may ("extended_who"), $arg), cf::NDI_UNIQUE | cf::NDI_DK_ORANGE); 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);
87
88 1
89}; 53};
90 54
91cf::register_command seen => sub { 55cf::register_command seen => sub {
92 my ($pl, $args) = @_; 56 my ($pl, $args) = @_;
93 57
94 if (my ($login) = $args =~ /(\S+)/) { 58 if (my ($login) = $args =~ /(\S+)/) {
95 if ($login eq $pl->name) { 59 if ($login eq $pl->name) {
96 $pl->message ("Very funny, $login. Ha. Ha.", cf::NDI_UNIQUE); 60 $pl->message ("Very funny, $login. Ha. Ha.", cf::NDI_REPLY);
97 } elsif (cf::player::find_active $login) { 61 } elsif (cf::player::find_active $login) {
98 $pl->message ("$login is right here on this server!", cf::NDI_UNIQUE); 62 $pl->message ("$login is right here on this server!", cf::NDI_REPLY);
99 } elsif (cf::player::exists $login 63 } elsif (cf::player::exists $login
100 and stat cf::player::path $login) { 64 and stat cf::player::path $login) {
101 my $time = (stat _)[9]; 65 my $time = (stat _)[9];
102 66
103 $pl->message ("$login was last seen here " 67 $pl->message ("$login was last seen here "
104 . (POSIX::strftime "%Y-%m-%d %H:%M:%S +0000", gmtime $time) 68 . (POSIX::strftime "%Y-%m-%d %H:%M:%S +0000", gmtime $time)
105 . " which was " . (int +(time - $time) / 3600) . " hours ago.", cf::NDI_UNIQUE); 69 . " which was " . (int +(time - $time) / 3600) . " hours ago.", cf::NDI_REPLY);
106 } else { 70 } else {
107 $pl->message ("No player named $login is known to me.", cf::NDI_UNIQUE); 71 $pl->message ("No player named $login is known to me.", cf::NDI_REPLY);
108 } 72 }
109 } else { 73 } else {
110 $pl->message ("Usage: seen <player>", cf::NDI_UNIQUE); 74 $pl->message ("Usage: seen <player>", cf::NDI_REPLY);
111 } 75 }
112}; 76};
113 77
114cf::register_command body => sub { 78cf::register_command body => sub {
115 my ($ob) = @_; 79 my ($ob) = @_;
116 80
117 # Too hard to try and make a header that lines everything up, so just 81 # Too hard to try and make a header that lines everything up, so just
118 # give a description. (comment from C++) 82 # give a description. (comment from C++)
119 my $reply = 83 my $reply =
120 "The first column is the name of the body location.\n\n" 84 "The first column is the name of the body location.\r"
121 . "The second column is how many of those locations your body has.\n\n" 85 . "The second column is how many of those locations your body has.\r"
122 . "The third column is how many slots in that location are available.\n\n"; 86 . "The third column is how many slots in that location are available.\n\n";
123 87
124 $reply .= sprintf " %-20s %3s %5s\n", "Location", "You", "Avail"; 88 $reply .= sprintf " %-20s %3s %5s\n", "Location", "You", "Avail";
125 for (0 .. cf::NUM_BODY_LOCATIONS - 1) { 89 for (0 .. cf::NUM_BODY_LOCATIONS - 1) {
126 my $msg = cf::object::slot_nonuse_name $_; 90 my $msg = cf::object::slot_nonuse_name $_;
127 $msg =~ s/^.*? a //; 91 $msg =~ s/^.*? a //;
128 $reply .= sprintf " %-20s %3d %5d\n", $msg, $ob->slot_info ($_), $ob->slot_used ($_) 92 $reply .= sprintf " %-20s %3d %5d\n", $msg, $ob->slot_info ($_), $ob->slot_used ($_)
129 if $ob->slot_info ($_) or $ob->slot_used ($_); 93 if $ob->slot_info ($_) or $ob->slot_used ($_);
130 } 94 }
131 95
132 $reply .= "You are not allowed to wear armor\n\n" 96 $reply .= "You are not allowed to wear armor\r"
133 unless $ob->flag (cf::FLAG_USE_ARMOUR); 97 unless $ob->flag (cf::FLAG_USE_ARMOUR);
134 $reply .= "You are not allowed to use weapons\n\n" 98 $reply .= "You are not allowed to use weapons\r"
135 unless $ob->flag (cf::FLAG_USE_WEAPON); 99 unless $ob->flag (cf::FLAG_USE_WEAPON);
136 100
137 $ob->reply (undef, $reply); 101 $ob->send_msg ("c/body" => $reply, cf::NDI_REPLY);
138
139 1
140}; 102};
141 103
142cf::register_command mark => sub { 104cf::register_command mark => sub {
143 my ($pl, $arg) = @_; 105 my ($pl, $arg) = @_;
144 106
… …
155 117
156 $pl->reply (undef, $ob 118 $pl->reply (undef, $ob
157 ? (sprintf "%s %s * is marked.", $ob->name, $ob->title) 119 ? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
158 : "You have no marked object."); 120 : "You have no marked object.");
159 } 121 }
160
161 1
162}; 122};
163 123
164for my $cmd ("run", "fire") { 124for my $cmd ("run", "fire") {
165 my $oncmd = "${cmd}_on"; 125 my $oncmd = "${cmd}_on";
166 cf::register_command $cmd => sub { 126 cf::register_command $cmd => sub {
… …
169 $ob->reply (undef, "Can't $cmd into a non adjacent square.") 129 $ob->reply (undef, "Can't $cmd into a non adjacent square.")
170 if $arg < 0 or $arg >= 9; 130 if $arg < 0 or $arg >= 9;
171 131
172 $ob->contr->$oncmd (1); 132 $ob->contr->$oncmd (1);
173 $ob->move_player ($arg); 133 $ob->move_player ($arg);
174
175 1
176 }; 134 };
177 135
178 cf::register_command "${cmd}_stop" => sub { 136 cf::register_command "${cmd}_stop" => sub {
179 my ($ob) = @_; 137 my ($ob) = @_;
180 138
181 $ob->contr->$oncmd (0); 139 $ob->contr->$oncmd (0);
182
183 1
184 }; 140 };
185} 141}
186 142
187cf::register_command mapinfo => sub { 143cf::register_command mapinfo => sub {
188 my ($ob) = @_; 144 my ($ob) = @_;
189 145
190 my $observe = $ob->contr->observe; 146 my $observe = $ob->contr->observe;
191 147
192 my $map = $observe->map 148 my $map = $observe->map
193 or return; 149 or return;
150
194 $ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $observe->region->longname)); 151 my $msg = sprintf "%s (%s)\r%s", $map->name, $map->path, $observe->region->longname;
195 $ob->reply (undef, (sprintf "players: %d difficulty: %d size: %d start: %dx%d timeout: %d", 152 $msg .= sprintf "\rplayers: %d difficulty: %d size: %d start: %dx%d timeout: %d",
196 (scalar $map->players), $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout)) 153 (scalar $map->players), $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout
197 if $ob->flag (cf::FLAG_WIZ); 154 if $ob->flag (cf::FLAG_WIZ);
198 $ob->reply (undef, $map->msg);
199 155
200 1 156 $ob->send_msg ("c/mapinfo" => $msg, cf::NDI_REPLY | cf::NDI_CLEAR);
201}; 157};
202 158
203cf::register_command whereami => sub { 159cf::register_command whereami => sub {
204 my ($ob) = @_; 160 my ($ob) = @_;
205 161
206 my $reg = $ob->contr->observe->region; 162 my $reg = $ob->contr->observe->region;
207 $ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg)); 163 $ob->send_msg ("c/who" => (sprintf "You are %s.\n\n%s", $reg->longname, $reg->msg), cf::NDI_REPLY | cf::NDI_CLEAR);
164};
208 165
166cf::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};
209 1 173 }
174
175 my $msg = "T<In the world currently there are:>\n\n"
176 . join "", map { sprintf " C<%3d >player(s) %s\r", $count{$_}, $_ } sort keys %count;
177
178 $ob->send_msg ("c/who" => $msg, cf::NDI_REPLY | cf::NDI_CLEAR);
179};
180
181cf::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);
210}; 186};
211 187
212sub _set_mode($$$@) { 188sub _set_mode($$$@) {
213 my ($name, $ob, $arg, $slot, @choices) = @_; 189 my ($name, $ob, $arg, $slot, @choices) = @_;
214 190
… …
226 202
227cf::register_command applymode => sub { 203cf::register_command applymode => sub {
228 my ($ob, $arg) = @_; 204 my ($ob, $arg) = @_;
229 205
230 _set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always); 206 _set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
231
232 1
233}; 207};
234 208
235cf::register_command petmode => sub { 209cf::register_command petmode => sub {
236 my ($ob, $arg) = @_; 210 my ($ob, $arg) = @_;
237 211
238 _set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena); 212 _set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
239
240 1
241}; 213};
242 214
243cf::register_command usekeys => sub { 215cf::register_command usekeys => sub {
244 my ($ob, $arg) = @_; 216 my ($ob, $arg) = @_;
245 217
246 _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers); 218 _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
247
248 1
249}; 219};
250 220
251cf::register_command hintmode => sub { 221cf::register_command hintmode => sub {
252 my ($ob, $arg) = @_; 222 my ($ob, $arg) = @_;
253 223
254 _set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide); 224 _set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);
255
256 1
257}; 225};
258 226
259cf::register_command afk => sub { 227cf::register_command afk => sub {
260 my ($ob, $arg) = @_; 228 my ($ob, $arg) = @_;
261 229
262 $ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1); 230 $ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
263 $ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK"); 231 $ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
264
265 1
266}; 232};
267 233
268cf::register_command sound => sub { 234cf::register_command sound => sub {
269 my ($ob, $arg) = @_; 235 my ($ob, $arg) = @_;
270 236
271 $ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1); 237 $ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
272 $ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden..."); 238 $ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
273
274 1
275}; 239};
276 240
277cf::register_command brace => sub { 241cf::register_command brace => sub {
278 my ($ob, $arg) = @_; 242 my ($ob, $arg) = @_;
279 243
280 $ob->contr->braced ($ob->contr->braced ? 0 : 1); 244 $ob->contr->braced ($ob->contr->braced ? 0 : 1);
281 $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced."); 245 $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
282
283 1
284}; 246};
285 247
286cf::register_command 'output-rate' => sub { 248cf::register_command 'output-rate' => sub {
287 my ($ob, $arg) = @_; 249 my ($ob, $arg) = @_;
288 250
… …
291 253
292 # minimum is 5k/s 254 # minimum is 5k/s
293 # maximum is 100k/s, this should be configurable 255 # maximum is 100k/s, this should be configurable
294 $ob->contr->ns->max_rate ((List::Util::max 5000, List::Util::min 100000, $arg) * $cf::TICK); 256 $ob->contr->ns->max_rate ((List::Util::max 5000, List::Util::min 100000, $arg) * $cf::TICK);
295 $ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK); 257 $ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
296
297 1
298}; 258};
299 259
300cf::register_command 'output-count' => sub { 260cf::register_command 'output-count' => sub {
301 my ($ob, $arg) = @_; 261 my ($ob, $arg) = @_;
302 262
… …
305 265
306 $arg = 4 if $arg < 4; 266 $arg = 4 if $arg < 4;
307 267
308 $ob->contr->outputs_count ($arg); 268 $ob->contr->outputs_count ($arg);
309 $ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count); 269 $ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
310
311 1
312}; 270};
313 271
314cf::register_command 'output-sync' => sub { 272cf::register_command 'output-sync' => sub {
315 my ($ob, $arg) = @_; 273 my ($ob, $arg) = @_;
316 274
… …
319 277
320 $arg = 0.5 if $arg < 0.5; 278 $arg = 0.5 if $arg < 0.5;
321 279
322 $ob->contr->outputs_sync ($arg / $cf::TICK); 280 $ob->contr->outputs_sync ($arg / $cf::TICK);
323 $ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK); 281 $ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
324
325 1
326}; 282};
327 283
328# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to 284# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
329# some other level (which may also be 0), this does not get echoed, 285# some other level (which may also be 0), this does not get echoed,
330# but it does get set. 286# but it does get set.
… …
337 293
338 return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.") 294 return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
339 if $arg =~ /^\d+$/ and $arg <= 100; 295 if $arg =~ /^\d+$/ and $arg <= 100;
340 296
341 $ob->reply (undef, "Incorrect parameters for wimpy: $arg"); 297 $ob->reply (undef, "Incorrect parameters for wimpy: $arg");
342
343 1
344}; 298};
345 299
346cf::register_command peaceful => sub { 300cf::register_command peaceful => sub {
347 my ($ob, $arg) = @_; 301 my ($ob, $arg) = @_;
348 302
… …
351 ." if you want to become hostile or in temple of Valriel" 305 ." if you want to become hostile or in temple of Valriel"
352 ." if you want to become peaceful again."); 306 ." if you want to become peaceful again.");
353 307
354 #$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1); 308 #$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
355 #$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players."); 309 #$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
310};
356 311
312sub rename_to($$$) {
313 my ($ob, $from, $to) = @_;
314
315 $to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
316 or return $ob->message ("rename: name must consist only of letters, digits, spaces and a few other things.");
317
318 127 >= length $to
319 or return $ob->message ("rename: new name must be <= 127 characters.");
320
321 my $item;
322
323 if (length $from) {
324 $item = $ob->find_best_object_match ($from)
325 or return $ob->message ("rename: could not find a matching item to rename.");
326 } else {
327 $item = $ob->find_marked_object
328 or return $ob->message ("rename: no from name and no marked item found to rename.");
329 }
330
331 $item->custom_name (length $to ? $to : undef);
332
333 if (length $to) {
334 $item->custom_name ($to);
335 $ob->message ("Your " . $item->base_name . " will now be called $to.");
336 } else {
337 $item->custom_name (undef);
338 $ob->message ("You stop calling your " . $item->base_name . " with weird names.");
339 }
340
341 $ob->esrv_update_item (cf::UPD_NAME, $item);
342
357 1 343 1
358}; 344}
359 345
360cf::register_command rename => sub { 346cf::register_command rename => sub {
361 my ($ob, $arg) = @_; 347 my ($ob, $arg) = @_;
362 348
363 $ob->speed_left ($ob->speed_left - 0.25); 349 $ob->speed_left ($ob->speed_left - 0.25);
… …
377 # does not unquote $1 or $3 363 # does not unquote $1 or $3
378 rename_to $ob, $2||$1, $4||$3; 364 rename_to $ob, $2||$1, $4||$3;
379 } else { 365 } else {
380 $ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"'); 366 $ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
381 } 367 }
382
383 1
384}; 368};
385 369
386cf::register_command uptime => sub { 370cf::register_command uptime => sub {
387 my ($ob, $arg) = @_; 371 my ($ob, $arg) = @_;
388 372
389 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;
390 my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400; 374 my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
391 $ob->reply (undef, "server started $startup, uptime ${runtime}\d"); 375 $ob->send_msg ("c/uptime" => "server started $startup, uptime ${runtime}\d", cf::NDI_REPLY | cf::NDI_CLEAR);
392
393 1
394}; 376};
395 377
396my %IN_MEMORY = ( 378my %IN_MEMORY = (
397 cf::MAP_IN_MEMORY => "I", 379 cf::MAP_ACTIVE => "I",
398 cf::MAP_SWAPPED => "S", 380 cf::MAP_SWAPPED => "S",
399 cf::MAP_LOADING => "L", 381 cf::MAP_LOADING => "L",
400); 382);
401 383
402cf::register_command maps => sub { 384cf::register_command maps => sub {
403 my ($ob, $arg) = @_; 385 my ($ob, $arg) = @_;
404 386
405 no re 'eval'; $arg = qr<$arg>; 387 no re 'eval'; $arg = qr<$arg>;
406 388
407 my $format = "%2s %1s %3s %5s %.60s\n"; 389 my $format = " %2s %1s %3s %5s %.60s\n";
408 390
409 $ob->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK | cf::NDI_UNIQUE); 391 my $msg = "\n" . sprintf $format, "Pl", "I", "Svd", "Reset", "Name";
410 392
411 for (sort keys %cf::MAP) { 393 for (sort keys %cf::MAP) {
412 my $map = $cf::MAP{$_} 394 my $map = $cf::MAP{$_}
413 or next; 395 or next;
414 396
… …
416 next if $map->{deny_list}; 398 next if $map->{deny_list};
417 399
418 my $svd = int $cf::RUNTIME - $map->{last_save}; 400 my $svd = int $cf::RUNTIME - $map->{last_save};
419 $svd = "++" if $svd > 99; 401 $svd = "++" if $svd > 99;
420 402
421 $ob->reply (undef, 403 $msg .= sprintf $format,
422 (sprintf $format,
423 (scalar $map->players), 404 (scalar $map->players),
424 $IN_MEMORY{$map->in_memory} || "?", 405 $IN_MEMORY{$map->in_memory} || "?",
425 $svd, 406 $svd,
426 (int $map->reset_at - $cf::RUNTIME), 407 (int $map->reset_at - $cf::RUNTIME),
427 $map->visible_name), 408 $map->visible_name;
428 cf::NDI_BLACK | cf::NDI_UNIQUE);
429 }
430
431 1 409 }
432};
433 410
411 $ob->send_msg ("c/mapinfo" => $msg, cf::NDI_REPLY | cf::NDI_CLEAR);
412};
413

Diff Legend

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