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::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::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++)
   my $reply =
       "The first column is the name of the body location.\n"
     . "The second column is how many of those locations your body has.\n"
     . "The third column is how many slots in that location are available.\n";

   $reply .= sprintf "%-20s %3s %5s\n", "Location", "You", "Avail";
   for (0 .. cf::NUM_BODY_LOCATIONS - 1) {
      my $msg = cf::object::slot_nonuse_name $_;
      $msg =~ s/^.*? a //;
      $reply .= sprintf "%-20s %3d %5d\n", $msg, $ob->slot_info ($_), $ob->slot_used ($_)
         if $ob->slot_info ($_) or $ob->slot_used ($_);
   }

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

   $ob->reply (undef, $reply);

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