server/ext/commands.ext

#! perl

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

cf::register_command applymode => sub {
   my ($ob, $arg) = @_;
   my @types = ("nochoice", "never", "always");
   my $mapping = {
      nochoice => 1,
      never    => 2,
      always   => 3,
   };

   my $oldmode = $ob->contr->unapply;
   my $oldmode_name = $types[$oldmode];

   return $ob->reply (undef, "applymode is set to $oldmode_name")
      unless $arg;

   return $ob->reply (undef, "applymode: Unknown options '$arg', valid options are @types")
      unless $mapping->{$arg};

   $ob->contr->unapply ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
                                               # but $arg would be 0 if a user enters an incorrect value
   $ob->reply (undef, "applymode" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $types[$ob->contr->unapply]);

   1
};

cf::register_command petmode => sub {
   my ($ob, $arg) = @_;
   my @types = ("normal", "sad", "defend", "arena");
   my $mapping = {
      normal => 1,
      sad    => 2,
      defend => 3,
      arena  => 4,
   };

   my $oldtype = $ob->contr->petmode;
   my $oldtype_name = $types[$oldtype];

   return $ob->reply (undef, "petmode is set to $oldtype_name")
      unless $arg;

   return $ob->reply (undef, "petmode: Unknown options '$arg', valid options are @types")
      unless $mapping->{$arg};

   $ob->contr->petmode ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
                                               # but $arg would be 0 if a user enters an incorrect value
   $ob->reply (undef, "petmode" . ($oldtype == $ob->contr->petmode ? "" : " now") . " set to " . $types[$ob->contr->petmode]);

   1
};

cf::register_command usekeys => sub {
   my ($ob, $arg) = @_;
   my @types = ("inventory", "keyrings", "containers");
   my $mapping = {
      inventory  => 1,
      keyrings   => 2,
      containers => 3,
   };

   my $oldtype = $ob->contr->usekeys;
   my $oldtype_name = $types[$oldtype];

   return $ob->reply (undef, "usekeys is set to $oldtype_name")
      unless $arg;

   return $ob->reply (undef, "usekeys: Unknown options '$arg', valid options are @types")
      unless $mapping->{$arg};

   $ob->contr->usekeys ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
                                               # but $arg would be 0 if a user enters an incorrect value
   $ob->reply (undef, "usekeys" . ($oldtype == $ob->contr->usekeys ? "" : " now") . " set to " . $types[$ob->contr->usekeys]);

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