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.53 by root, Fri Jul 6 02:51:21 2007 UTC vs.
Revision 1.61 by root, Tue Aug 14 12:17:34 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->send_msg (log => (join "\n\n", who_listing $ob->may ("extended_who"), $arg), cf::NDI_DK_ORANGE | cf::NDI_REPLY);
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) = @_;
189 145
146 my $observe = $ob->contr->observe;
147
190 my $map = $ob->contr->observe->map 148 my $map = $observe->map
191 or return; 149 or return;
150
192 $ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $ob->region->longname)); 151 my $msg = 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", 152 $msg .= sprintf "\n\nplayers: %d difficulty: %d size: %d start: %dx%d timeout: %d",
194 (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
195 if $ob->flag (cf::FLAG_WIZ); 154 if $ob->flag (cf::FLAG_WIZ);
196 $ob->reply (undef, $map->msg); 155 $ob->send_msg (log => $msg, cf::NDI_REPLY);
197
198 1
199}; 156};
200 157
201cf::register_command whereami => sub { 158cf::register_command whereami => sub {
202 my ($ob) = @_; 159 my ($ob) = @_;
203 160
204 my $reg = $ob->contr->observe->region; 161 my $reg = $ob->contr->observe->region;
205 $ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg)); 162 $ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg));
163};
206 164
165cf::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};
207 1 172 }
173
174 my $msg = "In the world currently there are:\n\n"
175 . join "", map "$count{$_} player(s) $_\n\n", sort keys %count;
176
177 $ob->send_msg (log => $msg, cf::NDI_REPLY);
178};
179
180cf::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);
208}; 185};
209 186
210sub _set_mode($$$@) { 187sub _set_mode($$$@) {
211 my ($name, $ob, $arg, $slot, @choices) = @_; 188 my ($name, $ob, $arg, $slot, @choices) = @_;
212 189
… …
224 201
225cf::register_command applymode => sub { 202cf::register_command applymode => sub {
226 my ($ob, $arg) = @_; 203 my ($ob, $arg) = @_;
227 204
228 _set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always); 205 _set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
229
230 1
231}; 206};
232 207
233cf::register_command petmode => sub { 208cf::register_command petmode => sub {
234 my ($ob, $arg) = @_; 209 my ($ob, $arg) = @_;
235 210
236 _set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena); 211 _set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
237
238 1
239}; 212};
240 213
241cf::register_command usekeys => sub { 214cf::register_command usekeys => sub {
242 my ($ob, $arg) = @_; 215 my ($ob, $arg) = @_;
243 216
244 _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers); 217 _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
245
246 1
247}; 218};
248 219
249cf::register_command hintmode => sub { 220cf::register_command hintmode => sub {
250 my ($ob, $arg) = @_; 221 my ($ob, $arg) = @_;
251 222
252 _set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide); 223 _set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);
253
254 1
255}; 224};
256 225
257cf::register_command afk => sub { 226cf::register_command afk => sub {
258 my ($ob, $arg) = @_; 227 my ($ob, $arg) = @_;
259 228
260 $ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1); 229 $ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
261 $ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK"); 230 $ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
262
263 1
264}; 231};
265 232
266cf::register_command sound => sub { 233cf::register_command sound => sub {
267 my ($ob, $arg) = @_; 234 my ($ob, $arg) = @_;
268 235
269 $ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1); 236 $ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
270 $ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden..."); 237 $ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
271
272 1
273}; 238};
274 239
275cf::register_command brace => sub { 240cf::register_command brace => sub {
276 my ($ob, $arg) = @_; 241 my ($ob, $arg) = @_;
277 242
278 $ob->contr->braced ($ob->contr->braced ? 0 : 1); 243 $ob->contr->braced ($ob->contr->braced ? 0 : 1);
279 $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced."); 244 $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
280
281 1
282}; 245};
283 246
284cf::register_command 'output-rate' => sub { 247cf::register_command 'output-rate' => sub {
285 my ($ob, $arg) = @_; 248 my ($ob, $arg) = @_;
286 249
287 return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK) 250 return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
288 unless $arg > 0; 251 unless $arg > 0;
289 252
290 # minimum is 2k/s 253 # minimum is 5k/s
254 # maximum is 100k/s, this should be configurable
291 $ob->contr->ns->max_rate ((List::Util::max 2048, $arg) * $cf::TICK); 255 $ob->contr->ns->max_rate ((List::Util::max 5000, List::Util::min 100000, $arg) * $cf::TICK);
292 $ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK); 256 $ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
293
294 1
295}; 257};
296 258
297cf::register_command 'output-count' => sub { 259cf::register_command 'output-count' => sub {
298 my ($ob, $arg) = @_; 260 my ($ob, $arg) = @_;
299 261
… …
302 264
303 $arg = 4 if $arg < 4; 265 $arg = 4 if $arg < 4;
304 266
305 $ob->contr->outputs_count ($arg); 267 $ob->contr->outputs_count ($arg);
306 $ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count); 268 $ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
307
308 1
309}; 269};
310 270
311cf::register_command 'output-sync' => sub { 271cf::register_command 'output-sync' => sub {
312 my ($ob, $arg) = @_; 272 my ($ob, $arg) = @_;
313 273
… …
316 276
317 $arg = 0.5 if $arg < 0.5; 277 $arg = 0.5 if $arg < 0.5;
318 278
319 $ob->contr->outputs_sync ($arg / $cf::TICK); 279 $ob->contr->outputs_sync ($arg / $cf::TICK);
320 $ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK); 280 $ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
321
322 1
323}; 281};
324 282
325# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to 283# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
326# some other level (which may also be 0), this does not get echoed, 284# some other level (which may also be 0), this does not get echoed,
327# but it does get set. 285# but it does get set.
… …
334 292
335 return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.") 293 return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
336 if $arg =~ /^\d+$/ and $arg <= 100; 294 if $arg =~ /^\d+$/ and $arg <= 100;
337 295
338 $ob->reply (undef, "Incorrect parameters for wimpy: $arg"); 296 $ob->reply (undef, "Incorrect parameters for wimpy: $arg");
339
340 1
341}; 297};
342 298
343cf::register_command peaceful => sub { 299cf::register_command peaceful => sub {
344 my ($ob, $arg) = @_; 300 my ($ob, $arg) = @_;
345 301
… …
348 ." if you want to become hostile or in temple of Valriel" 304 ." if you want to become hostile or in temple of Valriel"
349 ." if you want to become peaceful again."); 305 ." if you want to become peaceful again.");
350 306
351 #$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1); 307 #$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
352 #$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players."); 308 #$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
309};
353 310
311sub rename_to($$$) {
312 my ($ob, $from, $to) = @_;
313
314 $to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
315 or return $ob->message ("rename: name must consist only of letters, digits, spaces and a few other things.");
316
317 127 >= length $to
318 or return $ob->message ("rename: new name must be <= 127 characters.");
319
320 my $item;
321
322 if (length $from) {
323 $item = $ob->find_best_object_match ($from)
324 or return $ob->message ("rename: could not find a matching item to rename.");
325 } else {
326 $item = $ob->find_marked_object
327 or return $ob->message ("rename: no from name and no marked item found to rename.");
328 }
329
330 $item->custom_name (length $to ? $to : undef);
331
332 if (length $to) {
333 $item->custom_name ($to);
334 $ob->message ("Your " . $item->base_name . " will now be called $to.");
335 } else {
336 $item->custom_name (undef);
337 $ob->message ("You stop calling your " . $item->base_name . " with weird names.");
338 }
339
340 $ob->esrv_update_item (cf::UPD_NAME, $item);
341
354 1 342 1
355}; 343}
356 344
357cf::register_command rename => sub { 345cf::register_command rename => sub {
358 my ($ob, $arg) = @_; 346 my ($ob, $arg) = @_;
359 347
360 $ob->speed_left ($ob->speed_left - 0.25); 348 $ob->speed_left ($ob->speed_left - 0.25);
… …
374 # does not unquote $1 or $3 362 # does not unquote $1 or $3
375 rename_to $ob, $2||$1, $4||$3; 363 rename_to $ob, $2||$1, $4||$3;
376 } else { 364 } else {
377 $ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"'); 365 $ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
378 } 366 }
379
380 1
381}; 367};
382 368
383cf::register_command uptime => sub { 369cf::register_command uptime => sub {
384 my ($ob, $arg) = @_; 370 my ($ob, $arg) = @_;
385 371
386 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;
387 my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400; 373 my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
388 $ob->reply (undef, "server started $startup, uptime ${runtime}\d"); 374 $ob->reply (undef, "server started $startup, uptime ${runtime}\d");
389
390 1
391}; 375};
392 376
393my %IN_MEMORY = ( 377my %IN_MEMORY = (
394 cf::MAP_IN_MEMORY => "I", 378 cf::MAP_IN_MEMORY => "I",
395 cf::MAP_SWAPPED => "S", 379 cf::MAP_SWAPPED => "S",
… …
422 $svd, 406 $svd,
423 (int $map->reset_at - $cf::RUNTIME), 407 (int $map->reset_at - $cf::RUNTIME),
424 $map->visible_name), 408 $map->visible_name),
425 cf::NDI_BLACK | cf::NDI_UNIQUE); 409 cf::NDI_BLACK | cf::NDI_UNIQUE);
426 } 410 }
427
428 1
429}; 411};
430 412

Diff Legend

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