server/ext/commands.ext

#! perl # mandatory depends=irc

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 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->gender ? " [f]" : " [m]")
             . ($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\n"
     . "The second column is how many of those locations your body has.\n\n"
     . "The third column is how many slots in that location are available.\n\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\n"
      unless $ob->flag (cf::FLAG_USE_ARMOUR);
   $reply .= "You are not allowed to use weapons\n\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->contr->observe->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",
         (scalar $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->contr->observe->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 hintmode => sub {
   my ($ob, $arg) = @_;

   _set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);

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