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) = @_;

   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)",
      (
         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 - 0.25);

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

   1
};

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

   my @body_locations = ("in your range slot", "on your arm", "on your body", "on your head",
      "around your neck", "in your skill slot", "on your finger", "around your shoulders",
      "on your feet", "on your hands", "around your wrists", "around your waist");

   # 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 .. scalar @body_locations - 1) {
      $ob->reply (undef, (sprintf "%-30s %5d %5d", $body_locations[$_], $ob->body_info($_), $ob->body_used($_)))
         if $ob->body_info($_) or $ob->body_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
};

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

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

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

   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;

   $ob->contr->ns->max_rate ($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;

   $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, "Output sync time is presently " . $ob->contr->outputs_sync)
      unless $arg > 0;

   $ob->contr->outputs_sync ($arg);
   $ob->reply (undef, "Output sync time now set to " . $ob->contr->outputs_sync);

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