server/ext/commands.ext

#! perl # MANDATORY

use POSIX ();

# miscellaneous commands

sub rename_to($$$) {
   my ($ob, $from, $to) = @_;

   $to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
      or return $ob->message ("rename: name must consist only of letters, digits, spaces and a few other things.");

   127 >= length $to
      or return $ob->message ("rename: new name must be <= 127 characters.");

   my $item;

   if (length $from) {
      $item = $ob->find_best_object_match ($from)
         or return $ob->message ("rename: could not find a matching item to rename.");
   } else {
      $item = $ob->find_marked_object
         or return $ob->message ("rename: no from name and no marked item found to rename.");
   }

  $item->custom_name (length $to ? $to : undef);

  if (length $to) {
     $item->custom_name ($to);
     $ob->message ("Your " . $item->base_name . " will now be called $to.");
  } else {
     $item->custom_name (undef);
     $ob->message ("You stop calling your " . $item->base_name . " with weird names.");
  }

  $ob->esrv_update_item (cf::UPD_NAME, $item);

  1
}

sub ext::schmorp_irc::users; # HACK: TODO: replace by signal

sub who_listing(;$$) {
   my ($privileged, $select) = @_;

   my ($numwiz, $numafk) = (0, 0);
   my @pl;

   foreach my $pl (cf::player::list) {
      my $ns = $pl->ns or next;
      my $ob = $pl->ob;

      next unless $ob->map
               && ($privileged || !$pl->hidden);

      $numwiz++ if $ob->flag (cf::FLAG_WIZ);
      $numafk++ if $ns->afk;

      push @pl, $pl;
   }

   (
      "Total Players in The World. (" . (scalar @pl) . ") -- WIZ($numwiz) AFK($numafk) BOT(0)",
      (grep /$select/,
          map {
             my ($pl, $ob, $ns) = ($_, $_->ob, $_->ns);
      
             "* " . $ob->name . "/" . $ob->level . " " . (length $pl->own_title ? $pl->own_title : "the " . $pl->title)
             . ($pl->peaceful ? " [peaceful]" : " [HOSTILE]")
             . ($ns->afk ? " [AFK]" : "")
             . ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "")
             . " [" . $pl->ns->version . "]"
             . " [" . ($pl->peaceful || $privileged ? $ob->map->visible_name : $ob->region->name) . "]"
             . (sprintf " [rtt %.3fs]", $pl->ns->rtt * 1e-6)
             . ($privileged ? " " . $pl->ns->host : "")
          } sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl
      ),
      eval { "* IRC: " . join ", ", ext::schmorp_irc::users },
   )
}

cf::register_command who => sub {
   my ($ob, $arg) = @_;

   $ob->speed_left ($ob->speed_left - 4);

   $ob->reply (undef, (join "\n", who_listing $ob->may ("extended_who"), $arg), cf::NDI_UNIQUE | cf::NDI_DK_ORANGE);

   1
};

cf::register_command seen => sub {
   my ($pl, $args) = @_;

   if (my ($login) = $args =~ /(\S+)/) {
      if ($login eq $pl->name) {
         $pl->message ("Very funny, $login. Ha. Ha.", cf::NDI_UNIQUE);
      } elsif (cf::player::find_active $login) {
         $pl->message ("$login is right here on this server!", cf::NDI_UNIQUE);
      } elsif (cf::player::exists $login
               and stat cf::player::path $login) {
         my $time = (stat _)[9];

         $pl->message ("$login was last seen here "
                        . (POSIX::strftime "%Y-%m-%d %H:%M:%S +0000", gmtime $time)
                        . " which was " . (int +(time - $time) / 3600) . " hours ago.", cf::NDI_UNIQUE);
      } else {
         $pl->message ("No player named $login is known to me.", cf::NDI_UNIQUE);
      }
   } else {
      $pl->message ("Usage: seen <player>", cf::NDI_UNIQUE);
   }
};

cf::register_command body => sub {
   my ($ob) = @_;

   # Too hard to try and make a header that lines everything up, so just
   # give a description. (comment from C++)
   $ob->reply (undef, "The first column is the name of the body location.");
   $ob->reply (undef, "The second column is how many of those locations your body has.");
   $ob->reply (undef, "The third column is how many slots in that location are available.");

   for (0 .. cf::NUM_BODY_LOCATIONS - 1) {
      $ob->reply (undef, (sprintf "%-30s %5d %5d", cf::object::slot_use_name ($_), $ob->slot_info ($_), $ob->slot_used ($_)))
         if $ob->slot_info ($_) or $ob->slot_used ($_);
   }

   $ob->reply (undef, "You are not allowed to wear armor")
      unless $ob->flag (cf::FLAG_USE_ARMOUR);
   $ob->reply (undef, "You are not allowed to use weapons")
      unless $ob->flag (cf::FLAG_USE_WEAPON);

   1
};

cf::register_command mark => sub {
   my ($pl, $arg) = @_;

   if (length $arg) {
      my $ob = $pl->find_best_object_match ($arg);

      return $pl->reply (undef, "Could not find an object that matches $arg")
         unless $ob;

      $pl->contr->mark ($ob);
      $pl->reply (undef, (sprintf "Marked item %s", $ob->name, $ob->title));
   } else {
      my $ob = $pl->find_marked_object;

      $pl->reply (undef, $ob
         ? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
         : "You have no marked object.");
   }

   1
};

for my $cmd ("run", "fire") {
   my $oncmd = "${cmd}_on";
   cf::register_command $cmd => sub {
      my ($ob, $arg) = @_;

      $ob->reply (undef, "Can't $cmd into a non adjacent square.")
         if $arg < 0 or $arg >= 9;

      $ob->contr->$oncmd (1);
      $ob->move_player ($arg);
      
      1
   };
   
   cf::register_command "${cmd}_stop" => sub {
      my ($ob) = @_;
      
      $ob->contr->$oncmd (0);

      1
   };
}

cf::register_command mapinfo => sub {
   my ($ob) = @_;

   my $map = $ob->map
      or return;
   $ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $ob->region->longname));
   $ob->reply (undef, (sprintf "players: %d difficulty: %d size: %d start: %dx%d timeout: %d",
         $map->players, $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout))
      if $ob->flag (cf::FLAG_WIZ);
   $ob->reply (undef, $map->msg);

   1
};

cf::register_command whereami => sub {
   my ($ob) = @_;

   my $reg = $ob->region;
   $ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg));

   1
};

sub _set_mode($$$@) {
   my ($name, $ob, $arg, $slot, @choices) = @_;

   my $oldmode = $ob->contr->$slot;

   return $ob->reply (undef, "$name is set to $choices[$oldmode]")
      unless $arg;

   my ($idx) = grep $choices[$_] eq $arg, 0 .. $#choices
      or return $ob->reply (undef, "$name: Unknown options '$arg', valid options are @choices"), 1;

   $ob->contr->$slot ($idx);
   $ob->reply (undef, "$name" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $choices[$ob->contr->$slot]);
}

cf::register_command applymode => sub {
   my ($ob, $arg) = @_;

   _set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);

   1
};

cf::register_command petmode => sub {
   my ($ob, $arg) = @_;

   _set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);

   1
};

cf::register_command usekeys => sub {
   my ($ob, $arg) = @_;

   _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);

   1
};

cf::register_command afk => sub {
   my ($ob, $arg) = @_;

   $ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
   $ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");

   1
};

cf::register_command sound => sub {
   my ($ob, $arg) = @_;

   $ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
   $ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");

   1
};

cf::register_command brace => sub {
   my ($ob, $arg) = @_;

   $ob->contr->braced ($ob->contr->braced ? 0 : 1);
   $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");

   1
};

cf::register_command 'output-rate' => sub {
   my ($ob, $arg) = @_;

   return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
      unless $arg > 0;

   # minimum is 2k/s
   $ob->contr->ns->max_rate ((List::Util::max 2048, $arg) * $cf::TICK);
   $ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);

   1
};

cf::register_command 'output-count' => sub {
   my ($ob, $arg) = @_;

   return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
      unless $arg > 0;

   $arg = 4 if $arg < 4;

   $ob->contr->outputs_count ($arg);
   $ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);

   1
};

cf::register_command 'output-sync' => sub {
   my ($ob, $arg) = @_;

   return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
      unless length $arg;

   $arg = 0.5 if $arg < 0.5;

   $ob->contr->outputs_sync ($arg / $cf::TICK);
   $ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);

   1
};

# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
# some other level (which may also be 0), this does not get echoed,
# but it does get set.
cf::register_command wimpy => sub {
   my ($ob, $arg) = @_;

   my $wimpy = $ob->run_away;
   return $ob->reply (undef, "Your current wimpy level is $wimpy.")
      if $arg eq "";

   return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
      if $arg =~ /^\d+$/ and $arg <= 100;

   $ob->reply (undef, "Incorrect parameters for wimpy: $arg");

   1
};

cf::register_command peaceful => sub {
   my ($ob, $arg) = @_;

   $ob->reply (undef, "You cannot change your peaceful setting with this command."
                     ." Please speak to the priest in the temple of Gorokh"
                     ." if you want to become hostile or in temple of Valriel"
                     ." if you want to become peaceful again.");

   #$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
   #$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");

   1
};

cf::register_command rename => sub {
   my ($ob, $arg) = @_;

   $ob->speed_left ($ob->speed_left - 0.25);

   if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>]*)> \s*$/x) {
      # compatibility syntax
      rename_to $ob, $1, $2;
   } elsif ($arg =~ /
               ^\s*
               (?:
                  (?: "((?:[^"]+|\\.)*)" | (\S+) )
               \s+)?
               to \s+
               (?: "((?:[^"]+|\\.)*)" | (\S+) )
               \s*$
            /x) {
      # does not unquote $1 or $3
      rename_to $ob, $2||$1, $4||$3;
   } else {
      $ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
   }

   1
};

cf::register_command uptime => sub {
   my ($ob, $arg) = @_;

   my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
   my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
   $ob->reply (undef, "server started $startup, uptime ${runtime}\d");

   1
};

my %IN_MEMORY = (
   cf::MAP_IN_MEMORY => "I",
   cf::MAP_SWAPPED   => "S",
   cf::MAP_LOADING   => "L",
);

cf::register_command maps => sub {
   my ($ob, $arg) = @_;

   no re 'eval'; $arg = qr<$arg>;

   my $format = "%2s %1s %3s %5s %.60s\n";

   $ob->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK | cf::NDI_UNIQUE);

   for (sort keys %cf::MAP) {
      my $map = $cf::MAP{$_}
         or next;

      next unless $map->path =~ $arg;
      next if $map->{deny_list};

      my $svd = int $cf::RUNTIME - $map->{last_save};
      $svd = "++" if $svd > 99;

      $ob->reply (undef,
                  (sprintf $format,
                   (scalar $map->players), 
                   $IN_MEMORY{$map->in_memory} || "?",
                   $svd,
                   (int $map->reset_at - $cf::RUNTIME),
                   $map->visible_name),
                  cf::NDI_BLACK | cf::NDI_UNIQUE);
   }

   1
};

Revision:	1.43
Committed:	Mon May 7 03:05:58 2007 UTC (17 years ago) by root
Branch:	MAIN
Changes since 1.42:	+3 -7 lines
Log Message:	- add two new slots for shields and combat weapons - make slots into bitfields, they are not too speed-critical and this saves 16 bytes in the object structure. - add accessors to body lcoation names etc. to perl - use those in the body command
#	User	Rev	Content
1	root	1.35	#! perl # MANDATORY
2	root	1.1
3			use POSIX ();
4
5			# miscellaneous commands
6
7			sub rename_to($$$) {
8			my ($ob, $from, $to) = @_;
9
10	root	1.12	$to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
11	root	1.1	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	root	1.31	$item = $ob->find_marked_object
23	root	1.1	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
41			sub ext::schmorp_irc::users; # HACK: TODO: replace by signal
42
43	root	1.42	sub who_listing(;$$) {
44			my ($privileged, $select) = @_;
45	root	1.1
46			my ($numwiz, $numafk) = (0, 0);
47			my @pl;
48
49			foreach my $pl (cf::player::list) {
50	root	1.5	my $ns = $pl->ns or next;
51	root	1.1	my $ob = $pl->ob;
52
53			next unless $ob->map
54			&& ($privileged \|\| !$pl->hidden);
55
56			$numwiz++ if $ob->flag (cf::FLAG_WIZ);
57	root	1.5	$numafk++ if $ns->afk;
58	root	1.1
59			push @pl, $pl;
60			}
61
62			(
63			"Total Players in The World. (" . (scalar @pl) . ") -- WIZ($numwiz) AFK($numafk) BOT(0)",
64	root	1.42	(grep /$select/,
65			map {
66			my ($pl, $ob, $ns) = ($_, $_->ob, $_->ns);
67
68			"* " . $ob->name . "/" . $ob->level . " " . (length $pl->own_title ? $pl->own_title : "the " . $pl->title)
69			. ($pl->peaceful ? " [peaceful]" : " [HOSTILE]")
70			. ($ns->afk ? " [AFK]" : "")
71			. ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "")
72			. " [" . $pl->ns->version . "]"
73			. " [" . ($pl->peaceful \|\| $privileged ? $ob->map->visible_name : $ob->region->name) . "]"
74			. (sprintf " [rtt %.3fs]", $pl->ns->rtt * 1e-6)
75			. ($privileged ? " " . $pl->ns->host : "")
76			} sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl
77	root	1.1	),
78			eval { "* IRC: " . join ", ", ext::schmorp_irc::users },
79			)
80			}
81
82			cf::register_command who => sub {
83			my ($ob, $arg) = @_;
84
85	root	1.42	$ob->speed_left ($ob->speed_left - 4);
86	root	1.1
87	root	1.42	$ob->reply (undef, (join "\n", who_listing $ob->may ("extended_who"), $arg), cf::NDI_UNIQUE \| cf::NDI_DK_ORANGE);
88	root	1.1
89			1
90			};
91
92	root	1.40	cf::register_command seen => sub {
93			my ($pl, $args) = @_;
94
95			if (my ($login) = $args =~ /(\S+)/) {
96			if ($login eq $pl->name) {
97			$pl->message ("Very funny, $login. Ha. Ha.", cf::NDI_UNIQUE);
98			} elsif (cf::player::find_active $login) {
99			$pl->message ("$login is right here on this server!", cf::NDI_UNIQUE);
100			} elsif (cf::player::exists $login
101			and stat cf::player::path $login) {
102			my $time = (stat _)[9];
103
104			$pl->message ("$login was last seen here "
105			. (POSIX::strftime "%Y-%m-%d %H:%M:%S +0000", gmtime $time)
106			. " which was " . (int +(time - $time) / 3600) . " hours ago.", cf::NDI_UNIQUE);
107			} else {
108			$pl->message ("No player named $login is known to me.", cf::NDI_UNIQUE);
109			}
110			} else {
111			$pl->message ("Usage: seen <player>", cf::NDI_UNIQUE);
112			}
113			};
114
115	pippijn	1.27	cf::register_command body => sub {
116			my ($ob) = @_;
117
118			# Too hard to try and make a header that lines everything up, so just
119			# give a description. (comment from C++)
120			$ob->reply (undef, "The first column is the name of the body location.");
121			$ob->reply (undef, "The second column is how many of those locations your body has.");
122			$ob->reply (undef, "The third column is how many slots in that location are available.");
123
124	root	1.43	for (0 .. cf::NUM_BODY_LOCATIONS - 1) {
125			$ob->reply (undef, (sprintf "%-30s %5d %5d", cf::object::slot_use_name ($_), $ob->slot_info ($_), $ob->slot_used ($_)))
126			if $ob->slot_info ($_) or $ob->slot_used ($_);
127	pippijn	1.27	}
128
129			$ob->reply (undef, "You are not allowed to wear armor")
130			unless $ob->flag (cf::FLAG_USE_ARMOUR);
131			$ob->reply (undef, "You are not allowed to use weapons")
132			unless $ob->flag (cf::FLAG_USE_WEAPON);
133
134			1
135			};
136
137	pippijn	1.28	cf::register_command mark => sub {
138			my ($pl, $arg) = @_;
139
140	pippijn	1.32	if (length $arg) {
141	pippijn	1.28	my $ob = $pl->find_best_object_match ($arg);
142
143			return $pl->reply (undef, "Could not find an object that matches $arg")
144			unless $ob;
145
146	pippijn	1.29	$pl->contr->mark ($ob);
147	pippijn	1.28	$pl->reply (undef, (sprintf "Marked item %s", $ob->name, $ob->title));
148	pippijn	1.32	} else {
149			my $ob = $pl->find_marked_object;
150
151			$pl->reply (undef, $ob
152			? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
153			: "You have no marked object.");
154	pippijn	1.28	}
155
156			1
157			};
158
159			for my $cmd ("run", "fire") {
160			my $oncmd = "${cmd}_on";
161			cf::register_command $cmd => sub {
162			my ($ob, $arg) = @_;
163
164	pippijn	1.34	$ob->reply (undef, "Can't $cmd into a non adjacent square.")
165	pippijn	1.28	if $arg < 0 or $arg >= 9;
166
167	pippijn	1.34	$ob->contr->$oncmd (1);
168			$ob->move_player ($arg);
169	pippijn	1.28
170			1
171			};
172	pippijn	1.34
173	pippijn	1.28	cf::register_command "${cmd}_stop" => sub {
174			my ($ob) = @_;
175
176			$ob->contr->$oncmd (0);
177
178			1
179			};
180			}
181
182	pippijn	1.26	cf::register_command mapinfo => sub {
183			my ($ob) = @_;
184
185			my $map = $ob->map
186			or return;
187			$ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $ob->region->longname));
188			$ob->reply (undef, (sprintf "players: %d difficulty: %d size: %d start: %dx%d timeout: %d",
189			$map->players, $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout))
190			if $ob->flag (cf::FLAG_WIZ);
191			$ob->reply (undef, $map->msg);
192
193			1
194			};
195
196	pippijn	1.25	cf::register_command whereami => sub {
197			my ($ob) = @_;
198
199			my $reg = $ob->region;
200			$ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg));
201
202			1
203			};
204
205	root	1.31	sub _set_mode($$$@) {
206			my ($name, $ob, $arg, $slot, @choices) = @_;
207	pippijn	1.23
208	root	1.31	my $oldmode = $ob->contr->$slot;
209	pippijn	1.23
210	root	1.31	return $ob->reply (undef, "$name is set to $choices[$oldmode]")
211	pippijn	1.23	unless $arg;
212
213	root	1.31	my ($idx) = grep $choices[$_] eq $arg, 0 .. $#choices
214			or return $ob->reply (undef, "$name: Unknown options '$arg', valid options are @choices"), 1;
215	pippijn	1.23
216	root	1.31	$ob->contr->$slot ($idx);
217			$ob->reply (undef, "$name" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $choices[$ob->contr->$slot]);
218			}
219
220			cf::register_command applymode => sub {
221			my ($ob, $arg) = @_;
222
223			_set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
224	pippijn	1.23
225			1
226			};
227
228			cf::register_command petmode => sub {
229			my ($ob, $arg) = @_;
230
231	root	1.31	_set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
232	pippijn	1.23
233			1
234			};
235
236	pippijn	1.21	cf::register_command usekeys => sub {
237			my ($ob, $arg) = @_;
238
239	root	1.31	_set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
240	pippijn	1.22
241			1
242	pippijn	1.21	};
243
244	pippijn	1.19	cf::register_command afk => sub {
245			my ($ob, $arg) = @_;
246
247			$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
248			$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
249	pippijn	1.22
250			1
251	pippijn	1.19	};
252
253	pippijn	1.21	cf::register_command sound => sub {
254			my ($ob, $arg) = @_;
255
256			$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
257			$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
258	pippijn	1.22
259			1
260	pippijn	1.21	};
261
262	pippijn	1.20	cf::register_command brace => sub {
263			my ($ob, $arg) = @_;
264
265			$ob->contr->braced ($ob->contr->braced ? 0 : 1);
266			$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
267	pippijn	1.22
268			1
269	pippijn	1.20	};
270
271	root	1.35	cf::register_command 'output-rate' => sub {
272			my ($ob, $arg) = @_;
273
274			return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
275			unless $arg > 0;
276
277	root	1.39	# minimum is 2k/s
278			$ob->contr->ns->max_rate ((List::Util::max 2048, $arg) * $cf::TICK);
279	root	1.36	$ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
280	root	1.35
281			1
282			};
283
284	pippijn	1.24	cf::register_command 'output-count' => sub {
285			my ($ob, $arg) = @_;
286
287			return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
288			unless $arg > 0;
289
290	root	1.41	$arg = 4 if $arg < 4;
291
292	pippijn	1.24	$ob->contr->outputs_count ($arg);
293			$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
294
295			1
296			};
297
298			cf::register_command 'output-sync' => sub {
299			my ($ob, $arg) = @_;
300
301	root	1.38	return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
302			unless length $arg;
303	pippijn	1.24
304	root	1.41	$arg = 0.5 if $arg < 0.5;
305
306	root	1.38	$ob->contr->outputs_sync ($arg / $cf::TICK);
307			$ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
308	pippijn	1.24
309			1
310			};
311
312	pippijn	1.20	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
313			# some other level (which may also be 0), this does not get echoed,
314			# but it does get set.
315			cf::register_command wimpy => sub {
316			my ($ob, $arg) = @_;
317
318			my $wimpy = $ob->run_away;
319			return $ob->reply (undef, "Your current wimpy level is $wimpy.")
320			if $arg eq "";
321
322			return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
323			if $arg =~ /^\d+$/ and $arg <= 100;
324
325			$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
326	pippijn	1.22
327			1
328	pippijn	1.20	};
329
330			cf::register_command peaceful => sub {
331			my ($ob, $arg) = @_;
332
333			$ob->reply (undef, "You cannot change your peaceful setting with this command."
334			." Please speak to the priest in the temple of Gorokh"
335			." if you want to become hostile or in temple of Valriel"
336			." if you want to become peaceful again.");
337
338			#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
339			#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
340	pippijn	1.22
341			1
342	pippijn	1.20	};
343
344	root	1.1	cf::register_command rename => sub {
345			my ($ob, $arg) = @_;
346
347			$ob->speed_left ($ob->speed_left - 0.25);
348
349			if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>])> \s$/x) {
350			# compatibility syntax
351			rename_to $ob, $1, $2;
352			} elsif ($arg =~ /
353			^\s*
354			(?:
355			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
356			\s+)?
357			to \s+
358			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
359			\s*$
360			/x) {
361			# does not unquote $1 or $3
362			rename_to $ob, $2\|\|$1, $4\|\|$3;
363			} else {
364			$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
365			}
366
367			1
368			};
369
370			cf::register_command uptime => sub {
371			my ($ob, $arg) = @_;
372
373			my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
374			my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
375			$ob->reply (undef, "server started $startup, uptime ${runtime}\d");
376
377			1
378			};
379
380	root	1.8	my %IN_MEMORY = (
381			cf::MAP_IN_MEMORY => "I",
382			cf::MAP_SWAPPED => "S",
383			cf::MAP_LOADING => "L",
384			);
385
386	root	1.7	cf::register_command maps => sub {
387			my ($ob, $arg) = @_;
388
389			no re 'eval'; $arg = qr<$arg>;
390
391	root	1.13	my $format = "%2s %1s %3s %5s %.60s\n";
392	root	1.7
393	root	1.15	$ob->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK \| cf::NDI_UNIQUE);
394	root	1.7
395			for (sort keys %cf::MAP) {
396			my $map = $cf::MAP{$_}
397			or next;
398
399			next unless $map->path =~ $arg;
400	root	1.17	next if $map->{deny_list};
401	root	1.7
402	root	1.10	my $svd = int $cf::RUNTIME - $map->{last_save};
403			$svd = "++" if $svd > 99;
404
405	root	1.14	$ob->reply (undef,
406			(sprintf $format,
407			(scalar $map->players),
408			$IN_MEMORY{$map->in_memory} \|\| "?",
409			$svd,
410			(int $map->reset_at - $cf::RUNTIME),
411	root	1.17	$map->visible_name),
412	root	1.14	cf::NDI_BLACK \| cf::NDI_UNIQUE);
413	root	1.7	}
414
415			1
416			};
417