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.43 by root, Mon May 7 03:05:58 2007 UTC vs.
Revision 1.61 by root, Tue Aug 14 12:17:34 2007 UTC

1#! perl # MANDATORY 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
41sub ext::schmorp_irc::users; # HACK: TODO: replace by signal
42 6
43sub who_listing(;$$) { 7sub who_listing(;$$) {
44 my ($privileged, $select) = @_; 8 my ($privileged, $select) = @_;
45 9
46 my ($numwiz, $numafk) = (0, 0); 10 my ($numwiz, $numafk) = (0, 0);
… …
64 (grep /$select/, 28 (grep /$select/,
65 map { 29 map {
66 my ($pl, $ob, $ns) = ($_, $_->ob, $_->ns); 30 my ($pl, $ob, $ns) = ($_, $_->ob, $_->ns);
67 31
68 "* " . $ob->name . "/" . $ob->level . " " . (length $pl->own_title ? $pl->own_title : "the " . $pl->title) 32 "* " . $ob->name . "/" . $ob->level . " " . (length $pl->own_title ? $pl->own_title : "the " . $pl->title)
33 . ($pl->gender ? " [f]" : " [m]")
69 . ($pl->peaceful ? " [peaceful]" : " [HOSTILE]") 34 . ($pl->peaceful ? " [peaceful]" : " [HOSTILE]")
70 . ($ns->afk ? " [AFK]" : "") 35 . ($ns->afk ? " [AFK]" : "")
71 . ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "") 36 . ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "")
72 . " [" . $pl->ns->version . "]" 37 . " [" . $pl->ns->version . "]"
73 . " [" . ($pl->peaceful || $privileged ? $ob->map->visible_name : $ob->region->name) . "]" 38 . " [" . ($pl->peaceful || $privileged ? $ob->map->visible_name : $ob->region->name) . "]"
74 . (sprintf " [rtt %.3fs]", $pl->ns->rtt * 1e-6) 39 . (sprintf " [rtt %.3fs]", $pl->ns->tcpi_rtt * 1e-6)
75 . ($privileged ? " " . $pl->ns->host : "") 40 . ($privileged ? " " . $pl->ns->host : "")
76 } sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl 41 } sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl
77 ), 42 ),
78 eval { "* IRC: " . join ", ", ext::schmorp_irc::users }, 43 eval { "* IRC: " . join ", ", ext::irc::users },
79 ) 44 )
80} 45}
81 46
82cf::register_command who => sub { 47cf::register_command who => sub {
83 my ($ob, $arg) = @_; 48 my ($ob, $arg) = @_;
84 49
85 $ob->speed_left ($ob->speed_left - 4); 50 $ob->speed_left ($ob->speed_left - 4);
86 51
87 $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);
88
89 1
90}; 53};
91 54
92cf::register_command seen => sub { 55cf::register_command seen => sub {
93 my ($pl, $args) = @_; 56 my ($pl, $args) = @_;
94 57
… …
115cf::register_command body => sub { 78cf::register_command body => sub {
116 my ($ob) = @_; 79 my ($ob) = @_;
117 80
118 # 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
119 # give a description. (comment from C++) 82 # give a description. (comment from C++)
83 my $reply =
120 $ob->reply (undef, "The first column is the name of the body location."); 84 "The first column is the name of the body location.\n\n"
121 $ob->reply (undef, "The second column is how many of those locations your body has."); 85 . "The second column is how many of those locations your body has.\n\n"
122 $ob->reply (undef, "The third column is how many slots in that location are available."); 86 . "The third column is how many slots in that location are available.\n\n";
123 87
88 $reply .= sprintf " %-20s %3s %5s\n", "Location", "You", "Avail";
124 for (0 .. cf::NUM_BODY_LOCATIONS - 1) { 89 for (0 .. cf::NUM_BODY_LOCATIONS - 1) {
125 $ob->reply (undef, (sprintf "%-30s %5d %5d", cf::object::slot_use_name ($_), $ob->slot_info ($_), $ob->slot_used ($_))) 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 ($_)
126 if $ob->slot_info ($_) or $ob->slot_used ($_); 93 if $ob->slot_info ($_) or $ob->slot_used ($_);
127 } 94 }
128 95
129 $ob->reply (undef, "You are not allowed to wear armor") 96 $reply .= "You are not allowed to wear armor\n\n"
130 unless $ob->flag (cf::FLAG_USE_ARMOUR); 97 unless $ob->flag (cf::FLAG_USE_ARMOUR);
131 $ob->reply (undef, "You are not allowed to use weapons") 98 $reply .= "You are not allowed to use weapons\n\n"
132 unless $ob->flag (cf::FLAG_USE_WEAPON); 99 unless $ob->flag (cf::FLAG_USE_WEAPON);
133 100
134 1 101 $ob->reply (undef, $reply);
135}; 102};
136 103
137cf::register_command mark => sub { 104cf::register_command mark => sub {
138 my ($pl, $arg) = @_; 105 my ($pl, $arg) = @_;
139 106
… …
150 117
151 $pl->reply (undef, $ob 118 $pl->reply (undef, $ob
152 ? (sprintf "%s %s * is marked.", $ob->name, $ob->title) 119 ? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
153 : "You have no marked object."); 120 : "You have no marked object.");
154 } 121 }
155
156 1
157}; 122};
158 123
159for my $cmd ("run", "fire") { 124for my $cmd ("run", "fire") {
160 my $oncmd = "${cmd}_on"; 125 my $oncmd = "${cmd}_on";
161 cf::register_command $cmd => sub { 126 cf::register_command $cmd => sub {
… …
164 $ob->reply (undef, "Can't $cmd into a non adjacent square.") 129 $ob->reply (undef, "Can't $cmd into a non adjacent square.")
165 if $arg < 0 or $arg >= 9; 130 if $arg < 0 or $arg >= 9;
166 131
167 $ob->contr->$oncmd (1); 132 $ob->contr->$oncmd (1);
168 $ob->move_player ($arg); 133 $ob->move_player ($arg);
169
170 1
171 }; 134 };
172 135
173 cf::register_command "${cmd}_stop" => sub { 136 cf::register_command "${cmd}_stop" => sub {
174 my ($ob) = @_; 137 my ($ob) = @_;
175 138
176 $ob->contr->$oncmd (0); 139 $ob->contr->$oncmd (0);
177
178 1
179 }; 140 };
180} 141}
181 142
182cf::register_command mapinfo => sub { 143cf::register_command mapinfo => sub {
183 my ($ob) = @_; 144 my ($ob) = @_;
184 145
146 my $observe = $ob->contr->observe;
147
185 my $map = $ob->map 148 my $map = $observe->map
186 or return; 149 or return;
150
187 $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;
188 $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",
189 $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
190 if $ob->flag (cf::FLAG_WIZ); 154 if $ob->flag (cf::FLAG_WIZ);
191 $ob->reply (undef, $map->msg); 155 $ob->send_msg (log => $msg, cf::NDI_REPLY);
192
193 1
194}; 156};
195 157
196cf::register_command whereami => sub { 158cf::register_command whereami => sub {
197 my ($ob) = @_; 159 my ($ob) = @_;
198 160
199 my $reg = $ob->region; 161 my $reg = $ob->contr->observe->region;
200 $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};
201 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};
202 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);
203}; 185};
204 186
205sub _set_mode($$$@) { 187sub _set_mode($$$@) {
206 my ($name, $ob, $arg, $slot, @choices) = @_; 188 my ($name, $ob, $arg, $slot, @choices) = @_;
207 189
… …
219 201
220cf::register_command applymode => sub { 202cf::register_command applymode => sub {
221 my ($ob, $arg) = @_; 203 my ($ob, $arg) = @_;
222 204
223 _set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always); 205 _set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
224
225 1
226}; 206};
227 207
228cf::register_command petmode => sub { 208cf::register_command petmode => sub {
229 my ($ob, $arg) = @_; 209 my ($ob, $arg) = @_;
230 210
231 _set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena); 211 _set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
232
233 1
234}; 212};
235 213
236cf::register_command usekeys => sub { 214cf::register_command usekeys => sub {
237 my ($ob, $arg) = @_; 215 my ($ob, $arg) = @_;
238 216
239 _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers); 217 _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
218};
240 219
241 1 220cf::register_command hintmode => sub {
221 my ($ob, $arg) = @_;
222
223 _set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);
242}; 224};
243 225
244cf::register_command afk => sub { 226cf::register_command afk => sub {
245 my ($ob, $arg) = @_; 227 my ($ob, $arg) = @_;
246 228
247 $ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1); 229 $ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
248 $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");
249
250 1
251}; 231};
252 232
253cf::register_command sound => sub { 233cf::register_command sound => sub {
254 my ($ob, $arg) = @_; 234 my ($ob, $arg) = @_;
255 235
256 $ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1); 236 $ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
257 $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...");
258
259 1
260}; 238};
261 239
262cf::register_command brace => sub { 240cf::register_command brace => sub {
263 my ($ob, $arg) = @_; 241 my ($ob, $arg) = @_;
264 242
265 $ob->contr->braced ($ob->contr->braced ? 0 : 1); 243 $ob->contr->braced ($ob->contr->braced ? 0 : 1);
266 $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced."); 244 $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
267
268 1
269}; 245};
270 246
271cf::register_command 'output-rate' => sub { 247cf::register_command 'output-rate' => sub {
272 my ($ob, $arg) = @_; 248 my ($ob, $arg) = @_;
273 249
274 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)
275 unless $arg > 0; 251 unless $arg > 0;
276 252
277 # minimum is 2k/s 253 # minimum is 5k/s
254 # maximum is 100k/s, this should be configurable
278 $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);
279 $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);
280
281 1
282}; 257};
283 258
284cf::register_command 'output-count' => sub { 259cf::register_command 'output-count' => sub {
285 my ($ob, $arg) = @_; 260 my ($ob, $arg) = @_;
286 261
… …
289 264
290 $arg = 4 if $arg < 4; 265 $arg = 4 if $arg < 4;
291 266
292 $ob->contr->outputs_count ($arg); 267 $ob->contr->outputs_count ($arg);
293 $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);
294
295 1
296}; 269};
297 270
298cf::register_command 'output-sync' => sub { 271cf::register_command 'output-sync' => sub {
299 my ($ob, $arg) = @_; 272 my ($ob, $arg) = @_;
300 273
… …
303 276
304 $arg = 0.5 if $arg < 0.5; 277 $arg = 0.5 if $arg < 0.5;
305 278
306 $ob->contr->outputs_sync ($arg / $cf::TICK); 279 $ob->contr->outputs_sync ($arg / $cf::TICK);
307 $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);
308
309 1
310}; 281};
311 282
312# 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
313# 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,
314# but it does get set. 285# but it does get set.
… …
321 292
322 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.")
323 if $arg =~ /^\d+$/ and $arg <= 100; 294 if $arg =~ /^\d+$/ and $arg <= 100;
324 295
325 $ob->reply (undef, "Incorrect parameters for wimpy: $arg"); 296 $ob->reply (undef, "Incorrect parameters for wimpy: $arg");
326
327 1
328}; 297};
329 298
330cf::register_command peaceful => sub { 299cf::register_command peaceful => sub {
331 my ($ob, $arg) = @_; 300 my ($ob, $arg) = @_;
332 301
… …
335 ." if you want to become hostile or in temple of Valriel" 304 ." if you want to become hostile or in temple of Valriel"
336 ." if you want to become peaceful again."); 305 ." if you want to become peaceful again.");
337 306
338 #$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1); 307 #$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
339 #$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};
340 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
341 1 342 1
342}; 343}
343 344
344cf::register_command rename => sub { 345cf::register_command rename => sub {
345 my ($ob, $arg) = @_; 346 my ($ob, $arg) = @_;
346 347
347 $ob->speed_left ($ob->speed_left - 0.25); 348 $ob->speed_left ($ob->speed_left - 0.25);
… …
361 # does not unquote $1 or $3 362 # does not unquote $1 or $3
362 rename_to $ob, $2||$1, $4||$3; 363 rename_to $ob, $2||$1, $4||$3;
363 } else { 364 } else {
364 $ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"'); 365 $ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
365 } 366 }
366
367 1
368}; 367};
369 368
370cf::register_command uptime => sub { 369cf::register_command uptime => sub {
371 my ($ob, $arg) = @_; 370 my ($ob, $arg) = @_;
372 371
373 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;
374 my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400; 373 my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
375 $ob->reply (undef, "server started $startup, uptime ${runtime}\d"); 374 $ob->reply (undef, "server started $startup, uptime ${runtime}\d");
376
377 1
378}; 375};
379 376
380my %IN_MEMORY = ( 377my %IN_MEMORY = (
381 cf::MAP_IN_MEMORY => "I", 378 cf::MAP_IN_MEMORY => "I",
382 cf::MAP_SWAPPED => "S", 379 cf::MAP_SWAPPED => "S",
… …
409 $svd, 406 $svd,
410 (int $map->reset_at - $cf::RUNTIME), 407 (int $map->reset_at - $cf::RUNTIME),
411 $map->visible_name), 408 $map->visible_name),
412 cf::NDI_BLACK | cf::NDI_UNIQUE); 409 cf::NDI_BLACK | cf::NDI_UNIQUE);
413 } 410 }
414
415 1
416}; 411};
417 412

Diff Legend

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