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

Diff Legend

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