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.44 by root, Mon May 7 07:47:32 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
… …
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++)
120 my $reply = 83 my $reply =
121 "The first column is the name of the body location.\n" 84 "The first column is the name of the body location.\n\n"
122 . "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"
123 . "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";
124 87
125 $reply .= sprintf "%-20s %3s %5s\n", "Location", "You", "Avail"; 88 $reply .= sprintf " %-20s %3s %5s\n", "Location", "You", "Avail";
126 for (0 .. cf::NUM_BODY_LOCATIONS - 1) { 89 for (0 .. cf::NUM_BODY_LOCATIONS - 1) {
127 my $msg = cf::object::slot_nonuse_name $_; 90 my $msg = cf::object::slot_nonuse_name $_;
128 $msg =~ s/^.*? a //; 91 $msg =~ s/^.*? a //;
129 $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 ($_)
130 if $ob->slot_info ($_) or $ob->slot_used ($_); 93 if $ob->slot_info ($_) or $ob->slot_used ($_);
131 } 94 }
132 95
133 $reply .= "You are not allowed to wear armor\n" 96 $reply .= "You are not allowed to wear armor\n\n"
134 unless $ob->flag (cf::FLAG_USE_ARMOUR); 97 unless $ob->flag (cf::FLAG_USE_ARMOUR);
135 $reply .= "You are not allowed to use weapons\n" 98 $reply .= "You are not allowed to use weapons\n\n"
136 unless $ob->flag (cf::FLAG_USE_WEAPON); 99 unless $ob->flag (cf::FLAG_USE_WEAPON);
137 100
138 $ob->reply (undef, $reply); 101 $ob->reply (undef, $reply);
139
140 1
141}; 102};
142 103
143cf::register_command mark => sub { 104cf::register_command mark => sub {
144 my ($pl, $arg) = @_; 105 my ($pl, $arg) = @_;
145 106
… …
156 117
157 $pl->reply (undef, $ob 118 $pl->reply (undef, $ob
158 ? (sprintf "%s %s * is marked.", $ob->name, $ob->title) 119 ? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
159 : "You have no marked object."); 120 : "You have no marked object.");
160 } 121 }
161
162 1
163}; 122};
164 123
165for my $cmd ("run", "fire") { 124for my $cmd ("run", "fire") {
166 my $oncmd = "${cmd}_on"; 125 my $oncmd = "${cmd}_on";
167 cf::register_command $cmd => sub { 126 cf::register_command $cmd => sub {
… …
170 $ob->reply (undef, "Can't $cmd into a non adjacent square.") 129 $ob->reply (undef, "Can't $cmd into a non adjacent square.")
171 if $arg < 0 or $arg >= 9; 130 if $arg < 0 or $arg >= 9;
172 131
173 $ob->contr->$oncmd (1); 132 $ob->contr->$oncmd (1);
174 $ob->move_player ($arg); 133 $ob->move_player ($arg);
175
176 1
177 }; 134 };
178 135
179 cf::register_command "${cmd}_stop" => sub { 136 cf::register_command "${cmd}_stop" => sub {
180 my ($ob) = @_; 137 my ($ob) = @_;
181 138
182 $ob->contr->$oncmd (0); 139 $ob->contr->$oncmd (0);
183
184 1
185 }; 140 };
186} 141}
187 142
188cf::register_command mapinfo => sub { 143cf::register_command mapinfo => sub {
189 my ($ob) = @_; 144 my ($ob) = @_;
190 145
146 my $observe = $ob->contr->observe;
147
191 my $map = $ob->map 148 my $map = $observe->map
192 or return; 149 or return;
150
193 $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;
194 $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",
195 $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
196 if $ob->flag (cf::FLAG_WIZ); 154 if $ob->flag (cf::FLAG_WIZ);
197 $ob->reply (undef, $map->msg); 155 $ob->send_msg (log => $msg, cf::NDI_REPLY);
198
199 1
200}; 156};
201 157
202cf::register_command whereami => sub { 158cf::register_command whereami => sub {
203 my ($ob) = @_; 159 my ($ob) = @_;
204 160
205 my $reg = $ob->region; 161 my $reg = $ob->contr->observe->region;
206 $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};
207 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};
208 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);
209}; 185};
210 186
211sub _set_mode($$$@) { 187sub _set_mode($$$@) {
212 my ($name, $ob, $arg, $slot, @choices) = @_; 188 my ($name, $ob, $arg, $slot, @choices) = @_;
213 189
… …
225 201
226cf::register_command applymode => sub { 202cf::register_command applymode => sub {
227 my ($ob, $arg) = @_; 203 my ($ob, $arg) = @_;
228 204
229 _set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always); 205 _set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
230
231 1
232}; 206};
233 207
234cf::register_command petmode => sub { 208cf::register_command petmode => sub {
235 my ($ob, $arg) = @_; 209 my ($ob, $arg) = @_;
236 210
237 _set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena); 211 _set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
238
239 1
240}; 212};
241 213
242cf::register_command usekeys => sub { 214cf::register_command usekeys => sub {
243 my ($ob, $arg) = @_; 215 my ($ob, $arg) = @_;
244 216
245 _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers); 217 _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
218};
246 219
247 1 220cf::register_command hintmode => sub {
221 my ($ob, $arg) = @_;
222
223 _set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);
248}; 224};
249 225
250cf::register_command afk => sub { 226cf::register_command afk => sub {
251 my ($ob, $arg) = @_; 227 my ($ob, $arg) = @_;
252 228
253 $ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1); 229 $ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
254 $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");
255
256 1
257}; 231};
258 232
259cf::register_command sound => sub { 233cf::register_command sound => sub {
260 my ($ob, $arg) = @_; 234 my ($ob, $arg) = @_;
261 235
262 $ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1); 236 $ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
263 $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...");
264
265 1
266}; 238};
267 239
268cf::register_command brace => sub { 240cf::register_command brace => sub {
269 my ($ob, $arg) = @_; 241 my ($ob, $arg) = @_;
270 242
271 $ob->contr->braced ($ob->contr->braced ? 0 : 1); 243 $ob->contr->braced ($ob->contr->braced ? 0 : 1);
272 $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced."); 244 $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
273
274 1
275}; 245};
276 246
277cf::register_command 'output-rate' => sub { 247cf::register_command 'output-rate' => sub {
278 my ($ob, $arg) = @_; 248 my ($ob, $arg) = @_;
279 249
280 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)
281 unless $arg > 0; 251 unless $arg > 0;
282 252
283 # minimum is 2k/s 253 # minimum is 5k/s
254 # maximum is 100k/s, this should be configurable
284 $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);
285 $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);
286
287 1
288}; 257};
289 258
290cf::register_command 'output-count' => sub { 259cf::register_command 'output-count' => sub {
291 my ($ob, $arg) = @_; 260 my ($ob, $arg) = @_;
292 261
… …
295 264
296 $arg = 4 if $arg < 4; 265 $arg = 4 if $arg < 4;
297 266
298 $ob->contr->outputs_count ($arg); 267 $ob->contr->outputs_count ($arg);
299 $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);
300
301 1
302}; 269};
303 270
304cf::register_command 'output-sync' => sub { 271cf::register_command 'output-sync' => sub {
305 my ($ob, $arg) = @_; 272 my ($ob, $arg) = @_;
306 273
… …
309 276
310 $arg = 0.5 if $arg < 0.5; 277 $arg = 0.5 if $arg < 0.5;
311 278
312 $ob->contr->outputs_sync ($arg / $cf::TICK); 279 $ob->contr->outputs_sync ($arg / $cf::TICK);
313 $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);
314
315 1
316}; 281};
317 282
318# 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
319# 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,
320# but it does get set. 285# but it does get set.
… …
327 292
328 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.")
329 if $arg =~ /^\d+$/ and $arg <= 100; 294 if $arg =~ /^\d+$/ and $arg <= 100;
330 295
331 $ob->reply (undef, "Incorrect parameters for wimpy: $arg"); 296 $ob->reply (undef, "Incorrect parameters for wimpy: $arg");
332
333 1
334}; 297};
335 298
336cf::register_command peaceful => sub { 299cf::register_command peaceful => sub {
337 my ($ob, $arg) = @_; 300 my ($ob, $arg) = @_;
338 301
… …
341 ." if you want to become hostile or in temple of Valriel" 304 ." if you want to become hostile or in temple of Valriel"
342 ." if you want to become peaceful again."); 305 ." if you want to become peaceful again.");
343 306
344 #$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1); 307 #$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
345 #$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};
346 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
347 1 342 1
348}; 343}
349 344
350cf::register_command rename => sub { 345cf::register_command rename => sub {
351 my ($ob, $arg) = @_; 346 my ($ob, $arg) = @_;
352 347
353 $ob->speed_left ($ob->speed_left - 0.25); 348 $ob->speed_left ($ob->speed_left - 0.25);
… …
367 # does not unquote $1 or $3 362 # does not unquote $1 or $3
368 rename_to $ob, $2||$1, $4||$3; 363 rename_to $ob, $2||$1, $4||$3;
369 } else { 364 } else {
370 $ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"'); 365 $ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
371 } 366 }
372
373 1
374}; 367};
375 368
376cf::register_command uptime => sub { 369cf::register_command uptime => sub {
377 my ($ob, $arg) = @_; 370 my ($ob, $arg) = @_;
378 371
379 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;
380 my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400; 373 my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
381 $ob->reply (undef, "server started $startup, uptime ${runtime}\d"); 374 $ob->reply (undef, "server started $startup, uptime ${runtime}\d");
382
383 1
384}; 375};
385 376
386my %IN_MEMORY = ( 377my %IN_MEMORY = (
387 cf::MAP_IN_MEMORY => "I", 378 cf::MAP_IN_MEMORY => "I",
388 cf::MAP_SWAPPED => "S", 379 cf::MAP_SWAPPED => "S",
… …
415 $svd, 406 $svd,
416 (int $map->reset_at - $cf::RUNTIME), 407 (int $map->reset_at - $cf::RUNTIME),
417 $map->visible_name), 408 $map->visible_name),
418 cf::NDI_BLACK | cf::NDI_UNIQUE); 409 cf::NDI_BLACK | cf::NDI_UNIQUE);
419 } 410 }
420
421 1
422}; 411};
423 412

Diff Legend

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