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.48 by root, Sun Jun 24 01:09:27 2007 UTC vs.
Revision 1.59 by root, Fri Aug 10 05:27:38 2007 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);
… …
68 . ($pl->peaceful ? " [peaceful]" : " [HOSTILE]") 34 . ($pl->peaceful ? " [peaceful]" : " [HOSTILE]")
69 . ($ns->afk ? " [AFK]" : "") 35 . ($ns->afk ? " [AFK]" : "")
70 . ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "") 36 . ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "")
71 . " [" . $pl->ns->version . "]" 37 . " [" . $pl->ns->version . "]"
72 . " [" . ($pl->peaceful || $privileged ? $ob->map->visible_name : $ob->region->name) . "]" 38 . " [" . ($pl->peaceful || $privileged ? $ob->map->visible_name : $ob->region->name) . "]"
73 . (sprintf " [rtt %.3fs]", $pl->ns->rtt * 1e-6) 39 . (sprintf " [rtt %.3fs]", $pl->ns->tcpi_rtt * 1e-6)
74 . ($privileged ? " " . $pl->ns->host : "") 40 . ($privileged ? " " . $pl->ns->host : "")
75 } sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl 41 } sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl
76 ), 42 ),
77 eval { "* IRC: " . join ", ", ext::irc::users }, 43 eval { "* IRC: " . join ", ", ext::irc::users },
78 ) 44 )
… …
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->contr->ns->send_msg (log => (join "\n\n", who_listing $ob->may ("extended_who"), $arg), cf::NDI_DK_ORANGE);
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
… …
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" 84 "The first column is the name of the body location.\n\n"
121 . "The second column is how many of those locations your body has.\n" 85 . "The second column is how many of those locations your body has.\n\n"
122 . "The third column is how many slots in that location are available.\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" 96 $reply .= "You are not allowed to wear armor\n\n"
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" 98 $reply .= "You are not allowed to use weapons\n\n"
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->reply (undef, $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
146 my $observe = $ob->contr->observe;
147
190 my $map = $ob->map 148 my $map = $observe->map
191 or return; 149 or return;
192 $ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $ob->region->longname)); 150 $ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $observe->region->longname));
193 $ob->reply (undef, (sprintf "players: %d difficulty: %d size: %d start: %dx%d timeout: %d", 151 $ob->reply (undef, (sprintf "players: %d difficulty: %d size: %d start: %dx%d timeout: %d",
194 $map->players, $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout)) 152 (scalar $map->players), $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout))
195 if $ob->flag (cf::FLAG_WIZ); 153 if $ob->flag (cf::FLAG_WIZ);
196 $ob->reply (undef, $map->msg); 154 $ob->reply (undef, $map->msg);
197
198 1
199}; 155};
200 156
201cf::register_command whereami => sub { 157cf::register_command whereami => sub {
202 my ($ob) = @_; 158 my ($ob) = @_;
203 159
204 my $reg = $ob->region; 160 my $reg = $ob->contr->observe->region;
205 $ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg)); 161 $ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg));
162};
206 163
164cf::register_command whereabouts => sub {
165 my ($ob, $arg) = @_;
166
167 my %count;
168
169 for my $pl (cf::player::list) {
170 ++$count{$pl->ob->region->longname};
207 1 171 }
172
173 my $msg = "In the world currently there are:\n\n"
174 . join "", map "$count{$_} player(s) in $_\n\n", sort keys %count;
175
176 $ob->contr->ns->send_msg (log => $msg, cf::NDI_REPLY);
177};
178
179cf::register_command hiscore => sub {
180 my ($ob, $arg) = @_;
181
182 my $url = $cf::CFG->{hiscore_url};
183 $ob->contr->ns->send_msg (log => "See $url", cf::NDI_REPLY);
208}; 184};
209 185
210sub _set_mode($$$@) { 186sub _set_mode($$$@) {
211 my ($name, $ob, $arg, $slot, @choices) = @_; 187 my ($name, $ob, $arg, $slot, @choices) = @_;
212 188
… …
224 200
225cf::register_command applymode => sub { 201cf::register_command applymode => sub {
226 my ($ob, $arg) = @_; 202 my ($ob, $arg) = @_;
227 203
228 _set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always); 204 _set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
229
230 1
231}; 205};
232 206
233cf::register_command petmode => sub { 207cf::register_command petmode => sub {
234 my ($ob, $arg) = @_; 208 my ($ob, $arg) = @_;
235 209
236 _set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena); 210 _set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
237
238 1
239}; 211};
240 212
241cf::register_command usekeys => sub { 213cf::register_command usekeys => sub {
242 my ($ob, $arg) = @_; 214 my ($ob, $arg) = @_;
243 215
244 _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers); 216 _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
217};
245 218
246 1 219cf::register_command hintmode => sub {
220 my ($ob, $arg) = @_;
221
222 _set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);
247}; 223};
248 224
249cf::register_command afk => sub { 225cf::register_command afk => sub {
250 my ($ob, $arg) = @_; 226 my ($ob, $arg) = @_;
251 227
252 $ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1); 228 $ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
253 $ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK"); 229 $ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
254
255 1
256}; 230};
257 231
258cf::register_command sound => sub { 232cf::register_command sound => sub {
259 my ($ob, $arg) = @_; 233 my ($ob, $arg) = @_;
260 234
261 $ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1); 235 $ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
262 $ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden..."); 236 $ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
263
264 1
265}; 237};
266 238
267cf::register_command brace => sub { 239cf::register_command brace => sub {
268 my ($ob, $arg) = @_; 240 my ($ob, $arg) = @_;
269 241
270 $ob->contr->braced ($ob->contr->braced ? 0 : 1); 242 $ob->contr->braced ($ob->contr->braced ? 0 : 1);
271 $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced."); 243 $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
272
273 1
274}; 244};
275 245
276cf::register_command 'output-rate' => sub { 246cf::register_command 'output-rate' => sub {
277 my ($ob, $arg) = @_; 247 my ($ob, $arg) = @_;
278 248
279 return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK) 249 return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
280 unless $arg > 0; 250 unless $arg > 0;
281 251
282 # minimum is 2k/s 252 # minimum is 5k/s
253 # maximum is 100k/s, this should be configurable
283 $ob->contr->ns->max_rate ((List::Util::max 2048, $arg) * $cf::TICK); 254 $ob->contr->ns->max_rate ((List::Util::max 5000, List::Util::min 100000, $arg) * $cf::TICK);
284 $ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK); 255 $ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
285
286 1
287}; 256};
288 257
289cf::register_command 'output-count' => sub { 258cf::register_command 'output-count' => sub {
290 my ($ob, $arg) = @_; 259 my ($ob, $arg) = @_;
291 260
… …
294 263
295 $arg = 4 if $arg < 4; 264 $arg = 4 if $arg < 4;
296 265
297 $ob->contr->outputs_count ($arg); 266 $ob->contr->outputs_count ($arg);
298 $ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count); 267 $ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
299
300 1
301}; 268};
302 269
303cf::register_command 'output-sync' => sub { 270cf::register_command 'output-sync' => sub {
304 my ($ob, $arg) = @_; 271 my ($ob, $arg) = @_;
305 272
… …
308 275
309 $arg = 0.5 if $arg < 0.5; 276 $arg = 0.5 if $arg < 0.5;
310 277
311 $ob->contr->outputs_sync ($arg / $cf::TICK); 278 $ob->contr->outputs_sync ($arg / $cf::TICK);
312 $ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK); 279 $ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
313
314 1
315}; 280};
316 281
317# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to 282# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
318# some other level (which may also be 0), this does not get echoed, 283# some other level (which may also be 0), this does not get echoed,
319# but it does get set. 284# but it does get set.
… …
326 291
327 return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.") 292 return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
328 if $arg =~ /^\d+$/ and $arg <= 100; 293 if $arg =~ /^\d+$/ and $arg <= 100;
329 294
330 $ob->reply (undef, "Incorrect parameters for wimpy: $arg"); 295 $ob->reply (undef, "Incorrect parameters for wimpy: $arg");
331
332 1
333}; 296};
334 297
335cf::register_command peaceful => sub { 298cf::register_command peaceful => sub {
336 my ($ob, $arg) = @_; 299 my ($ob, $arg) = @_;
337 300
… …
340 ." if you want to become hostile or in temple of Valriel" 303 ." if you want to become hostile or in temple of Valriel"
341 ." if you want to become peaceful again."); 304 ." if you want to become peaceful again.");
342 305
343 #$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1); 306 #$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
344 #$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players."); 307 #$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
308};
345 309
310sub rename_to($$$) {
311 my ($ob, $from, $to) = @_;
312
313 $to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
314 or return $ob->message ("rename: name must consist only of letters, digits, spaces and a few other things.");
315
316 127 >= length $to
317 or return $ob->message ("rename: new name must be <= 127 characters.");
318
319 my $item;
320
321 if (length $from) {
322 $item = $ob->find_best_object_match ($from)
323 or return $ob->message ("rename: could not find a matching item to rename.");
324 } else {
325 $item = $ob->find_marked_object
326 or return $ob->message ("rename: no from name and no marked item found to rename.");
327 }
328
329 $item->custom_name (length $to ? $to : undef);
330
331 if (length $to) {
332 $item->custom_name ($to);
333 $ob->message ("Your " . $item->base_name . " will now be called $to.");
334 } else {
335 $item->custom_name (undef);
336 $ob->message ("You stop calling your " . $item->base_name . " with weird names.");
337 }
338
339 $ob->esrv_update_item (cf::UPD_NAME, $item);
340
346 1 341 1
347}; 342}
348 343
349cf::register_command rename => sub { 344cf::register_command rename => sub {
350 my ($ob, $arg) = @_; 345 my ($ob, $arg) = @_;
351 346
352 $ob->speed_left ($ob->speed_left - 0.25); 347 $ob->speed_left ($ob->speed_left - 0.25);
… …
366 # does not unquote $1 or $3 361 # does not unquote $1 or $3
367 rename_to $ob, $2||$1, $4||$3; 362 rename_to $ob, $2||$1, $4||$3;
368 } else { 363 } else {
369 $ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"'); 364 $ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
370 } 365 }
371
372 1
373}; 366};
374 367
375cf::register_command uptime => sub { 368cf::register_command uptime => sub {
376 my ($ob, $arg) = @_; 369 my ($ob, $arg) = @_;
377 370
378 my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME; 371 my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
379 my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400; 372 my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
380 $ob->reply (undef, "server started $startup, uptime ${runtime}\d"); 373 $ob->reply (undef, "server started $startup, uptime ${runtime}\d");
381
382 1
383}; 374};
384 375
385my %IN_MEMORY = ( 376my %IN_MEMORY = (
386 cf::MAP_IN_MEMORY => "I", 377 cf::MAP_IN_MEMORY => "I",
387 cf::MAP_SWAPPED => "S", 378 cf::MAP_SWAPPED => "S",
… …
414 $svd, 405 $svd,
415 (int $map->reset_at - $cf::RUNTIME), 406 (int $map->reset_at - $cf::RUNTIME),
416 $map->visible_name), 407 $map->visible_name),
417 cf::NDI_BLACK | cf::NDI_UNIQUE); 408 cf::NDI_BLACK | cf::NDI_UNIQUE);
418 } 409 }
419
420 1
421}; 410};
422 411

Diff Legend

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