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.25 by pippijn, Fri Mar 2 11:13:50 2007 UTC vs.
Revision 1.57 by root, Sat Jul 28 00:15:03 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->tcpi_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 $observe = $ob->contr->observe;
191
192 my $map = $observe->map
193 or return;
194 $ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $observe->region->longname));
195 $ob->reply (undef, (sprintf "players: %d difficulty: %d size: %d start: %dx%d timeout: %d",
196 (scalar $map->players), $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout))
197 if $ob->flag (cf::FLAG_WIZ);
198 $ob->reply (undef, $map->msg);
88 199
89 1 200 1
90}; 201};
91 202
92cf::register_command whereami => sub { 203cf::register_command whereami => sub {
93 my ($ob) = @_; 204 my ($ob) = @_;
94 205
95 my $reg = $ob->region; 206 my $reg = $ob->contr->observe->region;
96 $ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg)); 207 $ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg));
97 208
98 1 209 1
99}; 210};
100 211
212sub _set_mode($$$@) {
213 my ($name, $ob, $arg, $slot, @choices) = @_;
214
215 my $oldmode = $ob->contr->$slot;
216
217 return $ob->reply (undef, "$name is set to $choices[$oldmode]")
218 unless $arg;
219
220 my ($idx) = grep $choices[$_] eq $arg, 0 .. $#choices
221 or return $ob->reply (undef, "$name: Unknown options '$arg', valid options are @choices"), 1;
222
223 $ob->contr->$slot ($idx);
224 $ob->reply (undef, "$name" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $choices[$ob->contr->$slot]);
225}
226
101cf::register_command applymode => sub { 227cf::register_command applymode => sub {
102 my ($ob, $arg) = @_; 228 my ($ob, $arg) = @_;
103 my @types = ("nochoice", "never", "always");
104 my $mapping = {
105 nochoice => 1,
106 never => 2,
107 always => 3,
108 };
109 229
110 my $oldmode = $ob->contr->unapply; 230 _set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
111 my $oldmode_name = $types[$oldmode];
112
113 return $ob->reply (undef, "applymode is set to $oldmode_name")
114 unless $arg;
115
116 return $ob->reply (undef, "applymode: Unknown options '$arg', valid options are @types")
117 unless $mapping->{$arg};
118
119 $ob->contr->unapply ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
120 # but $arg would be 0 if a user enters an incorrect value
121 $ob->reply (undef, "applymode" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $types[$ob->contr->unapply]);
122 231
123 1 232 1
124}; 233};
125 234
126cf::register_command petmode => sub { 235cf::register_command petmode => sub {
127 my ($ob, $arg) = @_; 236 my ($ob, $arg) = @_;
128 my @types = ("normal", "sad", "defend", "arena");
129 my $mapping = {
130 normal => 1,
131 sad => 2,
132 defend => 3,
133 arena => 4,
134 };
135 237
136 my $oldtype = $ob->contr->petmode; 238 _set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
137 my $oldtype_name = $types[$oldtype];
138
139 return $ob->reply (undef, "petmode is set to $oldtype_name")
140 unless $arg;
141
142 return $ob->reply (undef, "petmode: Unknown options '$arg', valid options are @types")
143 unless $mapping->{$arg};
144
145 $ob->contr->petmode ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
146 # but $arg would be 0 if a user enters an incorrect value
147 $ob->reply (undef, "petmode" . ($oldtype == $ob->contr->petmode ? "" : " now") . " set to " . $types[$ob->contr->petmode]);
148 239
149 1 240 1
150}; 241};
151 242
152cf::register_command usekeys => sub { 243cf::register_command usekeys => sub {
153 my ($ob, $arg) = @_; 244 my ($ob, $arg) = @_;
154 my @types = ("inventory", "keyrings", "containers");
155 my $mapping = {
156 inventory => 1,
157 keyrings => 2,
158 containers => 3,
159 };
160 245
161 my $oldtype = $ob->contr->usekeys; 246 _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
162 my $oldtype_name = $types[$oldtype];
163 247
164 return $ob->reply (undef, "usekeys is set to $oldtype_name") 248 1
165 unless $arg; 249};
166 250
167 return $ob->reply (undef, "usekeys: Unknown options '$arg', valid options are @types") 251cf::register_command hintmode => sub {
168 unless $mapping->{$arg}; 252 my ($ob, $arg) = @_;
169 253
170 $ob->contr->usekeys ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0 254 _set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);
171 # but $arg would be 0 if a user enters an incorrect value
172 $ob->reply (undef, "usekeys" . ($oldtype == $ob->contr->usekeys ? "" : " now") . " set to " . $types[$ob->contr->usekeys]);
173 255
174 1 256 1
175}; 257};
176 258
177cf::register_command afk => sub { 259cf::register_command afk => sub {
… …
199 $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced."); 281 $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
200 282
201 1 283 1
202}; 284};
203 285
286cf::register_command 'output-rate' => sub {
287 my ($ob, $arg) = @_;
288
289 return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
290 unless $arg > 0;
291
292 # minimum is 5k/s
293 # maximum is 100k/s, this should be configurable
294 $ob->contr->ns->max_rate ((List::Util::max 5000, List::Util::min 100000, $arg) * $cf::TICK);
295 $ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
296
297 1
298};
299
204cf::register_command 'output-count' => sub { 300cf::register_command 'output-count' => sub {
205 my ($ob, $arg) = @_; 301 my ($ob, $arg) = @_;
206 302
207 return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count) 303 return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
208 unless $arg > 0; 304 unless $arg > 0;
209 305
306 $arg = 4 if $arg < 4;
307
210 $ob->contr->outputs_count ($arg); 308 $ob->contr->outputs_count ($arg);
211 $ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count); 309 $ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
212 310
213 1 311 1
214}; 312};
215 313
216cf::register_command 'output-sync' => sub { 314cf::register_command 'output-sync' => sub {
217 my ($ob, $arg) = @_; 315 my ($ob, $arg) = @_;
218 316
219 return $ob->reply (undef, "Output sync time is presently " . $ob->contr->outputs_sync) 317 return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
220 unless $arg > 0; 318 unless length $arg;
221 319
320 $arg = 0.5 if $arg < 0.5;
321
222 $ob->contr->outputs_sync ($arg); 322 $ob->contr->outputs_sync ($arg / $cf::TICK);
223 $ob->reply (undef, "Output sync time now set to " . $ob->contr->outputs_sync); 323 $ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
224 324
225 1 325 1
226}; 326};
227 327
228# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to 328# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to

Diff Legend

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