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.58 by root, Fri Aug 10 05:25:16 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);
… …
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->reply (undef, (join "\n", who_listing $ob->may ("extended_who"), $arg), cf::NDI_UNIQUE | 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
… …
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\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) = @_;
… …
194 $ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $observe->region->longname)); 150 $ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $observe->region->longname));
195 $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",
196 (scalar $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))
197 if $ob->flag (cf::FLAG_WIZ); 153 if $ob->flag (cf::FLAG_WIZ);
198 $ob->reply (undef, $map->msg); 154 $ob->reply (undef, $map->msg);
199
200 1
201}; 155};
202 156
203cf::register_command whereami => sub { 157cf::register_command whereami => sub {
204 my ($ob) = @_; 158 my ($ob) = @_;
205 159
206 my $reg = $ob->contr->observe->region; 160 my $reg = $ob->contr->observe->region;
207 $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};
208 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};
209 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);
210}; 184};
211 185
212sub _set_mode($$$@) { 186sub _set_mode($$$@) {
213 my ($name, $ob, $arg, $slot, @choices) = @_; 187 my ($name, $ob, $arg, $slot, @choices) = @_;
214 188
… …
226 200
227cf::register_command applymode => sub { 201cf::register_command applymode => sub {
228 my ($ob, $arg) = @_; 202 my ($ob, $arg) = @_;
229 203
230 _set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always); 204 _set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
231
232 1
233}; 205};
234 206
235cf::register_command petmode => sub { 207cf::register_command petmode => sub {
236 my ($ob, $arg) = @_; 208 my ($ob, $arg) = @_;
237 209
238 _set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena); 210 _set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
239
240 1
241}; 211};
242 212
243cf::register_command usekeys => sub { 213cf::register_command usekeys => sub {
244 my ($ob, $arg) = @_; 214 my ($ob, $arg) = @_;
245 215
246 _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers); 216 _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
247
248 1
249}; 217};
250 218
251cf::register_command hintmode => sub { 219cf::register_command hintmode => sub {
252 my ($ob, $arg) = @_; 220 my ($ob, $arg) = @_;
253 221
254 _set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide); 222 _set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);
255
256 1
257}; 223};
258 224
259cf::register_command afk => sub { 225cf::register_command afk => sub {
260 my ($ob, $arg) = @_; 226 my ($ob, $arg) = @_;
261 227
262 $ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1); 228 $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"); 229 $ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
264
265 1
266}; 230};
267 231
268cf::register_command sound => sub { 232cf::register_command sound => sub {
269 my ($ob, $arg) = @_; 233 my ($ob, $arg) = @_;
270 234
271 $ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1); 235 $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..."); 236 $ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
273
274 1
275}; 237};
276 238
277cf::register_command brace => sub { 239cf::register_command brace => sub {
278 my ($ob, $arg) = @_; 240 my ($ob, $arg) = @_;
279 241
280 $ob->contr->braced ($ob->contr->braced ? 0 : 1); 242 $ob->contr->braced ($ob->contr->braced ? 0 : 1);
281 $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced."); 243 $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
282
283 1
284}; 244};
285 245
286cf::register_command 'output-rate' => sub { 246cf::register_command 'output-rate' => sub {
287 my ($ob, $arg) = @_; 247 my ($ob, $arg) = @_;
288 248
… …
291 251
292 # minimum is 5k/s 252 # minimum is 5k/s
293 # maximum is 100k/s, this should be configurable 253 # 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); 254 $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); 255 $ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
296
297 1
298}; 256};
299 257
300cf::register_command 'output-count' => sub { 258cf::register_command 'output-count' => sub {
301 my ($ob, $arg) = @_; 259 my ($ob, $arg) = @_;
302 260
… …
305 263
306 $arg = 4 if $arg < 4; 264 $arg = 4 if $arg < 4;
307 265
308 $ob->contr->outputs_count ($arg); 266 $ob->contr->outputs_count ($arg);
309 $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);
310
311 1
312}; 268};
313 269
314cf::register_command 'output-sync' => sub { 270cf::register_command 'output-sync' => sub {
315 my ($ob, $arg) = @_; 271 my ($ob, $arg) = @_;
316 272
… …
319 275
320 $arg = 0.5 if $arg < 0.5; 276 $arg = 0.5 if $arg < 0.5;
321 277
322 $ob->contr->outputs_sync ($arg / $cf::TICK); 278 $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); 279 $ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
324
325 1
326}; 280};
327 281
328# 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
329# 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,
330# but it does get set. 284# but it does get set.
… …
337 291
338 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.")
339 if $arg =~ /^\d+$/ and $arg <= 100; 293 if $arg =~ /^\d+$/ and $arg <= 100;
340 294
341 $ob->reply (undef, "Incorrect parameters for wimpy: $arg"); 295 $ob->reply (undef, "Incorrect parameters for wimpy: $arg");
342
343 1
344}; 296};
345 297
346cf::register_command peaceful => sub { 298cf::register_command peaceful => sub {
347 my ($ob, $arg) = @_; 299 my ($ob, $arg) = @_;
348 300
… …
351 ." if you want to become hostile or in temple of Valriel" 303 ." if you want to become hostile or in temple of Valriel"
352 ." if you want to become peaceful again."); 304 ." if you want to become peaceful again.");
353 305
354 #$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1); 306 #$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."); 307 #$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
308};
356 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
357 1 341 1
358}; 342}
359 343
360cf::register_command rename => sub { 344cf::register_command rename => sub {
361 my ($ob, $arg) = @_; 345 my ($ob, $arg) = @_;
362 346
363 $ob->speed_left ($ob->speed_left - 0.25); 347 $ob->speed_left ($ob->speed_left - 0.25);
… …
377 # does not unquote $1 or $3 361 # does not unquote $1 or $3
378 rename_to $ob, $2||$1, $4||$3; 362 rename_to $ob, $2||$1, $4||$3;
379 } else { 363 } else {
380 $ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"'); 364 $ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
381 } 365 }
382
383 1
384}; 366};
385 367
386cf::register_command uptime => sub { 368cf::register_command uptime => sub {
387 my ($ob, $arg) = @_; 369 my ($ob, $arg) = @_;
388 370
389 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;
390 my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400; 372 my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
391 $ob->reply (undef, "server started $startup, uptime ${runtime}\d"); 373 $ob->reply (undef, "server started $startup, uptime ${runtime}\d");
392
393 1
394}; 374};
395 375
396my %IN_MEMORY = ( 376my %IN_MEMORY = (
397 cf::MAP_IN_MEMORY => "I", 377 cf::MAP_IN_MEMORY => "I",
398 cf::MAP_SWAPPED => "S", 378 cf::MAP_SWAPPED => "S",
… …
425 $svd, 405 $svd,
426 (int $map->reset_at - $cf::RUNTIME), 406 (int $map->reset_at - $cf::RUNTIME),
427 $map->visible_name), 407 $map->visible_name),
428 cf::NDI_BLACK | cf::NDI_UNIQUE); 408 cf::NDI_BLACK | cf::NDI_UNIQUE);
429 } 409 }
430
431 1
432}; 410};
433 411

Diff Legend

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