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.10 by root, Mon Jan 1 17:50:26 2007 UTC vs.
Revision 1.52 by root, Wed Jul 4 17:48:56 2007 UTC

1#! perl 1#! perl # mandatory depends=irc
2 2
3use POSIX (); 3use POSIX ();
4 4
5# miscellaneous commands 5# miscellaneous commands
6 6
7sub rename_to($$$) { 7sub rename_to($$$) {
8 my ($ob, $from, $to) = @_; 8 my ($ob, $from, $to) = @_;
9 9
10 $to =~ /^[a-zA-Z0-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."); 11 or return $ob->message ("rename: name must consist only of letters, digits, spaces and a few other things.");
12 12
13 127 >= length $to 13 127 >= length $to
14 or return $ob->message ("rename: new name must be <= 127 characters."); 14 or return $ob->message ("rename: new name must be <= 127 characters.");
15 15
… …
17 17
18 if (length $from) { 18 if (length $from) {
19 $item = $ob->find_best_object_match ($from) 19 $item = $ob->find_best_object_match ($from)
20 or return $ob->message ("rename: could not find a matching item to rename."); 20 or return $ob->message ("rename: could not find a matching item to rename.");
21 } else { 21 } else {
22 $item = $ob->find_marked_object () 22 $item = $ob->find_marked_object
23 or return $ob->message ("rename: no from name and no marked item found to rename."); 23 or return $ob->message ("rename: no from name and no marked item found to rename.");
24 } 24 }
25 25
26 $item->custom_name (length $to ? $to : undef); 26 $item->custom_name (length $to ? $to : undef);
27 27
… …
36 $ob->esrv_update_item (cf::UPD_NAME, $item); 36 $ob->esrv_update_item (cf::UPD_NAME, $item);
37 37
38 1 38 1
39} 39}
40 40
41sub ext::schmorp_irc::users; # HACK: TODO: replace by signal
42
43sub who_listing(;$) { 41sub who_listing(;$$) {
44 my ($privileged) = @_; 42 my ($privileged, $select) = @_;
45 43
46 my ($numwiz, $numafk) = (0, 0); 44 my ($numwiz, $numafk) = (0, 0);
47 my @pl; 45 my @pl;
48 46
49 foreach my $pl (cf::player::list) { 47 foreach my $pl (cf::player::list) {
… …
59 push @pl, $pl; 57 push @pl, $pl;
60 } 58 }
61 59
62 ( 60 (
63 "Total Players in The World. (" . (scalar @pl) . ") -- WIZ($numwiz) AFK($numafk) BOT(0)", 61 "Total Players in The World. (" . (scalar @pl) . ") -- WIZ($numwiz) AFK($numafk) BOT(0)",
64 ( 62 (grep /$select/,
65 map { 63 map {
66 my ($pl, $ob, $ns) = ($_, $_->ob, $_->ns); 64 my ($pl, $ob, $ns) = ($_, $_->ob, $_->ns);
67 65
68 "* " . $ob->name . "/" . $ob->level . " " . (length $pl->own_title ? $pl->own_title : "the " . $pl->title) 66 "* " . $ob->name . "/" . $ob->level . " " . (length $pl->own_title ? $pl->own_title : "the " . $pl->title)
67 . ($pl->gender ? " [f]" : " [m]")
69 . ($pl->peaceful ? " [peaceful]" : " [HOSTILE]") 68 . ($pl->peaceful ? " [peaceful]" : " [HOSTILE]")
70 . ($ns->afk ? " [AFK]" : "") 69 . ($ns->afk ? " [AFK]" : "")
71 . ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "") 70 . ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "")
72 . " [" . $pl->ns->version . "]" 71 . " [" . $pl->ns->version . "]"
73 . " [" . ($pl->peaceful || $privileged ? $ob->map->{path}->visible_name : $ob->map->region ? $ob->map->region->name : "the unknown") . "]" 72 . " [" . ($pl->peaceful || $privileged ? $ob->map->visible_name : $ob->region->name) . "]"
74 . (sprintf " [rtt %.3fs]", $pl->ns->rtt * 1e-6) 73 . (sprintf " [rtt %.3fs]", $pl->ns->rtt * 1e-6)
75 . ($privileged ? " " . $pl->ns->host : "") 74 . ($privileged ? " " . $pl->ns->host : "")
76 } sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl 75 } sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl
77 ), 76 ),
78 eval { "* IRC: " . join ", ", ext::schmorp_irc::users }, 77 eval { "* IRC: " . join ", ", ext::irc::users },
79 ) 78 )
80} 79}
81 80
82cf::register_command who => sub { 81cf::register_command who => sub {
83 my ($ob, $arg) = @_; 82 my ($ob, $arg) = @_;
84 83
85 $ob->speed_left ($ob->speed_left - 0.25); 84 $ob->speed_left ($ob->speed_left - 4);
86 85
87 $ob->reply (undef, (join "\n", who_listing $ob->may ("extended_who")), cf::NDI_UNIQUE | cf::NDI_DK_ORANGE); 86 $ob->reply (undef, (join "\n", who_listing $ob->may ("extended_who"), $arg), cf::NDI_UNIQUE | cf::NDI_DK_ORANGE);
87
88 1
89};
90
91cf::register_command seen => sub {
92 my ($pl, $args) = @_;
93
94 if (my ($login) = $args =~ /(\S+)/) {
95 if ($login eq $pl->name) {
96 $pl->message ("Very funny, $login. Ha. Ha.", cf::NDI_UNIQUE);
97 } elsif (cf::player::find_active $login) {
98 $pl->message ("$login is right here on this server!", cf::NDI_UNIQUE);
99 } elsif (cf::player::exists $login
100 and stat cf::player::path $login) {
101 my $time = (stat _)[9];
102
103 $pl->message ("$login was last seen here "
104 . (POSIX::strftime "%Y-%m-%d %H:%M:%S +0000", gmtime $time)
105 . " which was " . (int +(time - $time) / 3600) . " hours ago.", cf::NDI_UNIQUE);
106 } else {
107 $pl->message ("No player named $login is known to me.", cf::NDI_UNIQUE);
108 }
109 } else {
110 $pl->message ("Usage: seen <player>", cf::NDI_UNIQUE);
111 }
112};
113
114cf::register_command body => sub {
115 my ($ob) = @_;
116
117 # Too hard to try and make a header that lines everything up, so just
118 # give a description. (comment from C++)
119 my $reply =
120 "The first column is the name of the body location.\n\n"
121 . "The second column is how many of those locations your body has.\n\n"
122 . "The third column is how many slots in that location are available.\n\n";
123
124 $reply .= sprintf " %-20s %3s %5s\n", "Location", "You", "Avail";
125 for (0 .. cf::NUM_BODY_LOCATIONS - 1) {
126 my $msg = cf::object::slot_nonuse_name $_;
127 $msg =~ s/^.*? a //;
128 $reply .= sprintf " %-20s %3d %5d\n", $msg, $ob->slot_info ($_), $ob->slot_used ($_)
129 if $ob->slot_info ($_) or $ob->slot_used ($_);
130 }
131
132 $reply .= "You are not allowed to wear armor\n\n"
133 unless $ob->flag (cf::FLAG_USE_ARMOUR);
134 $reply .= "You are not allowed to use weapons\n\n"
135 unless $ob->flag (cf::FLAG_USE_WEAPON);
136
137 $ob->reply (undef, $reply);
138
139 1
140};
141
142cf::register_command mark => sub {
143 my ($pl, $arg) = @_;
144
145 if (length $arg) {
146 my $ob = $pl->find_best_object_match ($arg);
147
148 return $pl->reply (undef, "Could not find an object that matches $arg")
149 unless $ob;
150
151 $pl->contr->mark ($ob);
152 $pl->reply (undef, (sprintf "Marked item %s", $ob->name, $ob->title));
153 } else {
154 my $ob = $pl->find_marked_object;
155
156 $pl->reply (undef, $ob
157 ? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
158 : "You have no marked object.");
159 }
160
161 1
162};
163
164for my $cmd ("run", "fire") {
165 my $oncmd = "${cmd}_on";
166 cf::register_command $cmd => sub {
167 my ($ob, $arg) = @_;
168
169 $ob->reply (undef, "Can't $cmd into a non adjacent square.")
170 if $arg < 0 or $arg >= 9;
171
172 $ob->contr->$oncmd (1);
173 $ob->move_player ($arg);
174
175 1
176 };
177
178 cf::register_command "${cmd}_stop" => sub {
179 my ($ob) = @_;
180
181 $ob->contr->$oncmd (0);
182
183 1
184 };
185}
186
187cf::register_command mapinfo => sub {
188 my ($ob) = @_;
189
190 my $map = $ob->contr->observe->map
191 or return;
192 $ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $ob->region->longname));
193 $ob->reply (undef, (sprintf "players: %d difficulty: %d size: %d start: %dx%d timeout: %d",
194 $map->players, $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout))
195 if $ob->flag (cf::FLAG_WIZ);
196 $ob->reply (undef, $map->msg);
197
198 1
199};
200
201cf::register_command whereami => sub {
202 my ($ob) = @_;
203
204 my $reg = $ob->contr->observe->region;
205 $ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg));
206
207 1
208};
209
210sub _set_mode($$$@) {
211 my ($name, $ob, $arg, $slot, @choices) = @_;
212
213 my $oldmode = $ob->contr->$slot;
214
215 return $ob->reply (undef, "$name is set to $choices[$oldmode]")
216 unless $arg;
217
218 my ($idx) = grep $choices[$_] eq $arg, 0 .. $#choices
219 or return $ob->reply (undef, "$name: Unknown options '$arg', valid options are @choices"), 1;
220
221 $ob->contr->$slot ($idx);
222 $ob->reply (undef, "$name" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $choices[$ob->contr->$slot]);
223}
224
225cf::register_command applymode => sub {
226 my ($ob, $arg) = @_;
227
228 _set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
229
230 1
231};
232
233cf::register_command petmode => sub {
234 my ($ob, $arg) = @_;
235
236 _set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
237
238 1
239};
240
241cf::register_command usekeys => sub {
242 my ($ob, $arg) = @_;
243
244 _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
245
246 1
247};
248
249cf::register_command hintmode => sub {
250 my ($ob, $arg) = @_;
251
252 _set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);
253
254 1
255};
256
257cf::register_command afk => sub {
258 my ($ob, $arg) = @_;
259
260 $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");
262
263 1
264};
265
266cf::register_command sound => sub {
267 my ($ob, $arg) = @_;
268
269 $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...");
271
272 1
273};
274
275cf::register_command brace => sub {
276 my ($ob, $arg) = @_;
277
278 $ob->contr->braced ($ob->contr->braced ? 0 : 1);
279 $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
280
281 1
282};
283
284cf::register_command 'output-rate' => sub {
285 my ($ob, $arg) = @_;
286
287 return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
288 unless $arg > 0;
289
290 # minimum is 2k/s
291 $ob->contr->ns->max_rate ((List::Util::max 2048, $arg) * $cf::TICK);
292 $ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
293
294 1
295};
296
297cf::register_command 'output-count' => sub {
298 my ($ob, $arg) = @_;
299
300 return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
301 unless $arg > 0;
302
303 $arg = 4 if $arg < 4;
304
305 $ob->contr->outputs_count ($arg);
306 $ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
307
308 1
309};
310
311cf::register_command 'output-sync' => sub {
312 my ($ob, $arg) = @_;
313
314 return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
315 unless length $arg;
316
317 $arg = 0.5 if $arg < 0.5;
318
319 $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);
321
322 1
323};
324
325# 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,
327# but it does get set.
328cf::register_command wimpy => sub {
329 my ($ob, $arg) = @_;
330
331 my $wimpy = $ob->run_away;
332 return $ob->reply (undef, "Your current wimpy level is $wimpy.")
333 if $arg eq "";
334
335 return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
336 if $arg =~ /^\d+$/ and $arg <= 100;
337
338 $ob->reply (undef, "Incorrect parameters for wimpy: $arg");
339
340 1
341};
342
343cf::register_command peaceful => sub {
344 my ($ob, $arg) = @_;
345
346 $ob->reply (undef, "You cannot change your peaceful setting with this command."
347 ." Please speak to the priest in the temple of Gorokh"
348 ." if you want to become hostile or in temple of Valriel"
349 ." if you want to become peaceful again.");
350
351 #$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.");
88 353
89 1 354 1
90}; 355};
91 356
92cf::register_command rename => sub { 357cf::register_command rename => sub {
… …
134cf::register_command maps => sub { 399cf::register_command maps => sub {
135 my ($ob, $arg) = @_; 400 my ($ob, $arg) = @_;
136 401
137 no re 'eval'; $arg = qr<$arg>; 402 no re 'eval'; $arg = qr<$arg>;
138 403
139 my $format = "%2s %1s %3s %5s %-60.60s\n"; 404 my $format = "%2s %1s %3s %5s %.60s\n";
140 405
141 my $msg = sprintf $format, "Pl", "I", "Svd", "Reset", "Name"; 406 $ob->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK | cf::NDI_UNIQUE);
142 407
143 for (sort keys %cf::MAP) { 408 for (sort keys %cf::MAP) {
144 my $map = $cf::MAP{$_} 409 my $map = $cf::MAP{$_}
145 or next; 410 or next;
146 411
147 next unless $map->path =~ $arg; 412 next unless $map->path =~ $arg;
413 next if $map->{deny_list};
148 414
149 my $svd = int $cf::RUNTIME - $map->{last_save}; 415 my $svd = int $cf::RUNTIME - $map->{last_save};
150 $svd = "++" if $svd > 99; 416 $svd = "++" if $svd > 99;
151 417
152 $msg .= sprintf $format, 418 $ob->reply (undef,
419 (sprintf $format,
153 (scalar $map->players), 420 (scalar $map->players),
154 $IN_MEMORY{$map->in_memory} || "?", 421 $IN_MEMORY{$map->in_memory} || "?",
155 $svd, 422 $svd,
156 (int $map->reset_at - $cf::RUNTIME), 423 (int $map->reset_at - $cf::RUNTIME),
157 $map->{path}->visible_name; 424 $map->visible_name),
158 } 425 cf::NDI_BLACK | cf::NDI_UNIQUE);
159
160 $ob->reply (undef, $msg);
161
162 1 426 }
163};
164 427
428 1
429};
430

Diff Legend

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