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.22 by pippijn, Fri Mar 2 10:44:56 2007 UTC vs.
Revision 1.48 by root, Sun Jun 24 01:09:27 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
… …
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->visible_name : $ob->region->name) . "]" 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"
121 . "The second column is how many of those locations your body has.\n"
122 . "The third column is how many slots in that location are available.\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"
133 unless $ob->flag (cf::FLAG_USE_ARMOUR);
134 $reply .= "You are not allowed to use weapons\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->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->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);
88 237
89 1 238 1
90}; 239};
91 240
92cf::register_command usekeys => sub { 241cf::register_command usekeys => sub {
93 my ($ob, $arg) = @_; 242 my ($ob, $arg) = @_;
94 my @types = ("inventory", "keyrings", "containers");
95 my $mapping = {
96 inventory => 1,
97 keyrings => 2,
98 containers => 3,
99 };
100 243
101 my $oldtype = $ob->contr->usekeys; 244 _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
102 my $oldtype_name = $types[$oldtype];
103
104 return $ob->reply (undef, "usekeys is set to $oldtype_name")
105 unless $arg;
106
107 return $ob->reply (undef, "usekeys: Unknown options '$arg', valid options are inventory, keyrings, containers")
108 unless $mapping->{$arg};
109
110 $ob->contr->usekeys ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
111 # but $arg would be 0 if a user enters an incorrect value
112 $ob->reply (undef, "usekeys" . ($oldtype == $ob->contr->usekeys ? "" : " now") . " set to " . $types[$ob->contr->usekeys]);
113 245
114 1 246 1
115}; 247};
116 248
117cf::register_command afk => sub { 249cf::register_command afk => sub {
… …
135cf::register_command brace => sub { 267cf::register_command brace => sub {
136 my ($ob, $arg) = @_; 268 my ($ob, $arg) = @_;
137 269
138 $ob->contr->braced ($ob->contr->braced ? 0 : 1); 270 $ob->contr->braced ($ob->contr->braced ? 0 : 1);
139 $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced."); 271 $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
272
273 1
274};
275
276cf::register_command 'output-rate' => sub {
277 my ($ob, $arg) = @_;
278
279 return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
280 unless $arg > 0;
281
282 # minimum is 2k/s
283 $ob->contr->ns->max_rate ((List::Util::max 2048, $arg) * $cf::TICK);
284 $ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
285
286 1
287};
288
289cf::register_command 'output-count' => sub {
290 my ($ob, $arg) = @_;
291
292 return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
293 unless $arg > 0;
294
295 $arg = 4 if $arg < 4;
296
297 $ob->contr->outputs_count ($arg);
298 $ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
299
300 1
301};
302
303cf::register_command 'output-sync' => sub {
304 my ($ob, $arg) = @_;
305
306 return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
307 unless length $arg;
308
309 $arg = 0.5 if $arg < 0.5;
310
311 $ob->contr->outputs_sync ($arg / $cf::TICK);
312 $ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
140 313
141 1 314 1
142}; 315};
143 316
144# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to 317# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
… …
170 #$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1); 343 #$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
171 #$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players."); 344 #$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
172 345
173 1 346 1
174}; 347};
175
176 348
177cf::register_command rename => sub { 349cf::register_command rename => sub {
178 my ($ob, $arg) = @_; 350 my ($ob, $arg) = @_;
179 351
180 $ob->speed_left ($ob->speed_left - 0.25); 352 $ob->speed_left ($ob->speed_left - 0.25);

Diff Legend

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