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
};

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;

   $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;

   $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.39
Committed:	Mon Apr 2 19:56:11 2007 UTC (17 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.38:	+2 -1 lines
Log Message:	add untested ber integer encoding function
#	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			for my $cmd ("run", "fire") {
141			my $oncmd = "${cmd}_on";
142			cf::register_command $cmd => sub {
143			my ($ob, $arg) = @_;
144
145	pippijn	1.34	$ob->reply (undef, "Can't $cmd into a non adjacent square.")
146	pippijn	1.28	if $arg < 0 or $arg >= 9;
147
148	pippijn	1.34	$ob->contr->$oncmd (1);
149			$ob->move_player ($arg);
150	pippijn	1.28
151			1
152			};
153	pippijn	1.34
154	pippijn	1.28	cf::register_command "${cmd}_stop" => sub {
155			my ($ob) = @_;
156
157			$ob->contr->$oncmd (0);
158
159			1
160			};
161			}
162
163	pippijn	1.26	cf::register_command mapinfo => sub {
164			my ($ob) = @_;
165
166			my $map = $ob->map
167			or return;
168			$ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $ob->region->longname));
169			$ob->reply (undef, (sprintf "players: %d difficulty: %d size: %d start: %dx%d timeout: %d",
170			$map->players, $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout))
171			if $ob->flag (cf::FLAG_WIZ);
172			$ob->reply (undef, $map->msg);
173
174			1
175			};
176
177	pippijn	1.25	cf::register_command whereami => sub {
178			my ($ob) = @_;
179
180			my $reg = $ob->region;
181			$ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg));
182
183			1
184			};
185
186	root	1.31	sub _set_mode($$$@) {
187			my ($name, $ob, $arg, $slot, @choices) = @_;
188	pippijn	1.23
189	root	1.31	my $oldmode = $ob->contr->$slot;
190	pippijn	1.23
191	root	1.31	return $ob->reply (undef, "$name is set to $choices[$oldmode]")
192	pippijn	1.23	unless $arg;
193
194	root	1.31	my ($idx) = grep $choices[$_] eq $arg, 0 .. $#choices
195			or return $ob->reply (undef, "$name: Unknown options '$arg', valid options are @choices"), 1;
196	pippijn	1.23
197	root	1.31	$ob->contr->$slot ($idx);
198			$ob->reply (undef, "$name" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $choices[$ob->contr->$slot]);
199			}
200
201			cf::register_command applymode => sub {
202			my ($ob, $arg) = @_;
203
204			_set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
205	pippijn	1.23
206			1
207			};
208
209			cf::register_command petmode => sub {
210			my ($ob, $arg) = @_;
211
212	root	1.31	_set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
213	pippijn	1.23
214			1
215			};
216
217	pippijn	1.21	cf::register_command usekeys => sub {
218			my ($ob, $arg) = @_;
219
220	root	1.31	_set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
221	pippijn	1.22
222			1
223	pippijn	1.21	};
224
225	pippijn	1.19	cf::register_command afk => sub {
226			my ($ob, $arg) = @_;
227
228			$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
229			$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
230	pippijn	1.22
231			1
232	pippijn	1.19	};
233
234	pippijn	1.21	cf::register_command sound => sub {
235			my ($ob, $arg) = @_;
236
237			$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
238			$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
239	pippijn	1.22
240			1
241	pippijn	1.21	};
242
243	pippijn	1.20	cf::register_command brace => sub {
244			my ($ob, $arg) = @_;
245
246			$ob->contr->braced ($ob->contr->braced ? 0 : 1);
247			$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
248	pippijn	1.22
249			1
250	pippijn	1.20	};
251
252	root	1.35	cf::register_command 'output-rate' => sub {
253			my ($ob, $arg) = @_;
254
255			return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
256			unless $arg > 0;
257
258	root	1.39	# minimum is 2k/s
259			$ob->contr->ns->max_rate ((List::Util::max 2048, $arg) * $cf::TICK);
260	root	1.36	$ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
261	root	1.35
262			1
263			};
264
265	pippijn	1.24	cf::register_command 'output-count' => sub {
266			my ($ob, $arg) = @_;
267
268			return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
269			unless $arg > 0;
270
271			$ob->contr->outputs_count ($arg);
272			$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
273
274			1
275			};
276
277			cf::register_command 'output-sync' => sub {
278			my ($ob, $arg) = @_;
279
280	root	1.38	return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
281			unless length $arg;
282	pippijn	1.24
283	root	1.38	$ob->contr->outputs_sync ($arg / $cf::TICK);
284			$ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
285	pippijn	1.24
286			1
287			};
288
289	pippijn	1.20	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
290			# some other level (which may also be 0), this does not get echoed,
291			# but it does get set.
292			cf::register_command wimpy => sub {
293			my ($ob, $arg) = @_;
294
295			my $wimpy = $ob->run_away;
296			return $ob->reply (undef, "Your current wimpy level is $wimpy.")
297			if $arg eq "";
298
299			return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
300			if $arg =~ /^\d+$/ and $arg <= 100;
301
302			$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
303	pippijn	1.22
304			1
305	pippijn	1.20	};
306
307			cf::register_command peaceful => sub {
308			my ($ob, $arg) = @_;
309
310			$ob->reply (undef, "You cannot change your peaceful setting with this command."
311			." Please speak to the priest in the temple of Gorokh"
312			." if you want to become hostile or in temple of Valriel"
313			." if you want to become peaceful again.");
314
315			#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
316			#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
317	pippijn	1.22
318			1
319	pippijn	1.20	};
320
321	root	1.1	cf::register_command rename => sub {
322			my ($ob, $arg) = @_;
323
324			$ob->speed_left ($ob->speed_left - 0.25);
325
326			if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>])> \s$/x) {
327			# compatibility syntax
328			rename_to $ob, $1, $2;
329			} elsif ($arg =~ /
330			^\s*
331			(?:
332			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
333			\s+)?
334			to \s+
335			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
336			\s*$
337			/x) {
338			# does not unquote $1 or $3
339			rename_to $ob, $2\|\|$1, $4\|\|$3;
340			} else {
341			$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
342			}
343
344			1
345			};
346
347			cf::register_command uptime => sub {
348			my ($ob, $arg) = @_;
349
350			my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
351			my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
352			$ob->reply (undef, "server started $startup, uptime ${runtime}\d");
353
354			1
355			};
356
357	root	1.8	my %IN_MEMORY = (
358			cf::MAP_IN_MEMORY => "I",
359			cf::MAP_SWAPPED => "S",
360			cf::MAP_LOADING => "L",
361			);
362
363	root	1.7	cf::register_command maps => sub {
364			my ($ob, $arg) = @_;
365
366			no re 'eval'; $arg = qr<$arg>;
367
368	root	1.13	my $format = "%2s %1s %3s %5s %.60s\n";
369	root	1.7
370	root	1.15	$ob->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK \| cf::NDI_UNIQUE);
371	root	1.7
372			for (sort keys %cf::MAP) {
373			my $map = $cf::MAP{$_}
374			or next;
375
376			next unless $map->path =~ $arg;
377	root	1.17	next if $map->{deny_list};
378	root	1.7
379	root	1.10	my $svd = int $cf::RUNTIME - $map->{last_save};
380			$svd = "++" if $svd > 99;
381
382	root	1.14	$ob->reply (undef,
383			(sprintf $format,
384			(scalar $map->players),
385			$IN_MEMORY{$map->in_memory} \|\| "?",
386			$svd,
387			(int $map->reset_at - $cf::RUNTIME),
388	root	1.17	$map->visible_name),
389	root	1.14	cf::NDI_BLACK \| cf::NDI_UNIQUE);
390	root	1.7	}
391
392			1
393			};
394