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->tcpi_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 $observe = $ob->contr->observe;

   my $map = $observe->map
      or return;
   $ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $observe->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 5k/s
   # maximum is 100k/s, this should be configurable
   $ob->contr->ns->max_rate ((List::Util::max 5000, List::Util::min 100000, $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.57
Committed:	Sat Jul 28 00:15:03 2007 UTC (16 years, 10 months ago) by root
Branch:	MAIN
Changes since 1.56:	+3 -2 lines
Log Message:	allow perl access to the full tcpi structure. do some elaborate congestion control (very experimental, but better than the old way)
#	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	root	1.57	. (sprintf " [rtt %.3fs]", $pl->ns->tcpi_rtt * 1e-6)
74	root	1.42	. ($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.56	my $observe = $ob->contr->observe;
191	root	1.55
192	root	1.56	my $map = $observe->map
193	pippijn	1.26	or return;
194	root	1.56	$ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $observe->region->longname));
195	pippijn	1.26	$ob->reply (undef, (sprintf "players: %d difficulty: %d size: %d start: %dx%d timeout: %d",
196	root	1.53	(scalar $map->players), $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout))
197	pippijn	1.26	if $ob->flag (cf::FLAG_WIZ);
198			$ob->reply (undef, $map->msg);
199
200			1
201			};
202
203	pippijn	1.25	cf::register_command whereami => sub {
204			my ($ob) = @_;
205
206	root	1.50	my $reg = $ob->contr->observe->region;
207	pippijn	1.25	$ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg));
208
209			1
210			};
211
212	root	1.31	sub _set_mode($$$@) {
213			my ($name, $ob, $arg, $slot, @choices) = @_;
214	pippijn	1.23
215	root	1.31	my $oldmode = $ob->contr->$slot;
216	pippijn	1.23
217	root	1.31	return $ob->reply (undef, "$name is set to $choices[$oldmode]")
218	pippijn	1.23	unless $arg;
219
220	root	1.31	my ($idx) = grep $choices[$_] eq $arg, 0 .. $#choices
221			or return $ob->reply (undef, "$name: Unknown options '$arg', valid options are @choices"), 1;
222	pippijn	1.23
223	root	1.31	$ob->contr->$slot ($idx);
224			$ob->reply (undef, "$name" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $choices[$ob->contr->$slot]);
225			}
226
227			cf::register_command applymode => sub {
228			my ($ob, $arg) = @_;
229
230			_set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
231	pippijn	1.23
232			1
233			};
234
235			cf::register_command petmode => sub {
236			my ($ob, $arg) = @_;
237
238	root	1.31	_set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
239	pippijn	1.23
240			1
241			};
242
243	pippijn	1.21	cf::register_command usekeys => sub {
244			my ($ob, $arg) = @_;
245
246	root	1.31	_set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
247	pippijn	1.22
248			1
249	pippijn	1.21	};
250
251	root	1.51	cf::register_command hintmode => sub {
252			my ($ob, $arg) = @_;
253
254			_set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);
255
256			1
257			};
258
259	pippijn	1.19	cf::register_command afk => sub {
260			my ($ob, $arg) = @_;
261
262			$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
263			$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
264	pippijn	1.22
265			1
266	pippijn	1.19	};
267
268	pippijn	1.21	cf::register_command sound => sub {
269			my ($ob, $arg) = @_;
270
271			$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
272			$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
273	pippijn	1.22
274			1
275	pippijn	1.21	};
276
277	pippijn	1.20	cf::register_command brace => sub {
278			my ($ob, $arg) = @_;
279
280			$ob->contr->braced ($ob->contr->braced ? 0 : 1);
281			$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
282	pippijn	1.22
283			1
284	pippijn	1.20	};
285
286	root	1.35	cf::register_command 'output-rate' => sub {
287			my ($ob, $arg) = @_;
288
289			return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
290			unless $arg > 0;
291
292	root	1.54	# minimum is 5k/s
293	root	1.57	# maximum is 100k/s, this should be configurable
294			$ob->contr->ns->max_rate ((List::Util::max 5000, List::Util::min 100000, $arg) * $cf::TICK);
295	root	1.36	$ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
296	root	1.35
297			1
298			};
299
300	pippijn	1.24	cf::register_command 'output-count' => sub {
301			my ($ob, $arg) = @_;
302
303			return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
304			unless $arg > 0;
305
306	root	1.41	$arg = 4 if $arg < 4;
307
308	pippijn	1.24	$ob->contr->outputs_count ($arg);
309			$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
310
311			1
312			};
313
314			cf::register_command 'output-sync' => sub {
315			my ($ob, $arg) = @_;
316
317	root	1.38	return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
318			unless length $arg;
319	pippijn	1.24
320	root	1.41	$arg = 0.5 if $arg < 0.5;
321
322	root	1.38	$ob->contr->outputs_sync ($arg / $cf::TICK);
323			$ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
324	pippijn	1.24
325			1
326			};
327
328	pippijn	1.20	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
329			# some other level (which may also be 0), this does not get echoed,
330			# but it does get set.
331			cf::register_command wimpy => sub {
332			my ($ob, $arg) = @_;
333
334			my $wimpy = $ob->run_away;
335			return $ob->reply (undef, "Your current wimpy level is $wimpy.")
336			if $arg eq "";
337
338			return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
339			if $arg =~ /^\d+$/ and $arg <= 100;
340
341			$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
342	pippijn	1.22
343			1
344	pippijn	1.20	};
345
346			cf::register_command peaceful => sub {
347			my ($ob, $arg) = @_;
348
349			$ob->reply (undef, "You cannot change your peaceful setting with this command."
350			." Please speak to the priest in the temple of Gorokh"
351			." if you want to become hostile or in temple of Valriel"
352			." if you want to become peaceful again.");
353
354			#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
355			#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
356	pippijn	1.22
357			1
358	pippijn	1.20	};
359
360	root	1.1	cf::register_command rename => sub {
361			my ($ob, $arg) = @_;
362
363			$ob->speed_left ($ob->speed_left - 0.25);
364
365			if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>])> \s$/x) {
366			# compatibility syntax
367			rename_to $ob, $1, $2;
368			} elsif ($arg =~ /
369			^\s*
370			(?:
371			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
372			\s+)?
373			to \s+
374			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
375			\s*$
376			/x) {
377			# does not unquote $1 or $3
378			rename_to $ob, $2\|\|$1, $4\|\|$3;
379			} else {
380			$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
381			}
382
383			1
384			};
385
386			cf::register_command uptime => sub {
387			my ($ob, $arg) = @_;
388
389			my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
390			my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
391			$ob->reply (undef, "server started $startup, uptime ${runtime}\d");
392
393			1
394			};
395
396	root	1.8	my %IN_MEMORY = (
397			cf::MAP_IN_MEMORY => "I",
398			cf::MAP_SWAPPED => "S",
399			cf::MAP_LOADING => "L",
400			);
401
402	root	1.7	cf::register_command maps => sub {
403			my ($ob, $arg) = @_;
404
405			no re 'eval'; $arg = qr<$arg>;
406
407	root	1.13	my $format = "%2s %1s %3s %5s %.60s\n";
408	root	1.7
409	root	1.15	$ob->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK \| cf::NDI_UNIQUE);
410	root	1.7
411			for (sort keys %cf::MAP) {
412			my $map = $cf::MAP{$_}
413			or next;
414
415			next unless $map->path =~ $arg;
416	root	1.17	next if $map->{deny_list};
417	root	1.7
418	root	1.10	my $svd = int $cf::RUNTIME - $map->{last_save};
419			$svd = "++" if $svd > 99;
420
421	root	1.14	$ob->reply (undef,
422			(sprintf $format,
423			(scalar $map->players),
424			$IN_MEMORY{$map->in_memory} \|\| "?",
425			$svd,
426			(int $map->reset_at - $cf::RUNTIME),
427	root	1.17	$map->visible_name),
428	root	1.14	cf::NDI_BLACK \| cf::NDI_UNIQUE);
429	root	1.7	}
430
431			1
432			};
433