server/ext/commands.ext

#! perl # mandatory depends=irc

use POSIX ();

# miscellaneous commands

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->send_msg (log => (join "\n\n", who_listing $ob->may ("extended_who"), $arg), cf::NDI_DK_ORANGE | cf::NDI_REPLY);
};

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

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.");
   }
};

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);
   };
   
   cf::register_command "${cmd}_stop" => sub {
      my ($ob) = @_;
      
      $ob->contr->$oncmd (0);
   };
}

cf::register_command mapinfo => sub {
   my ($ob) = @_;

   my $observe = $ob->contr->observe;

   my $map = $observe->map
      or return;

   my $msg = sprintf "%s (%s) %s", $map->name, $map->path, $observe->region->longname;
   $msg .= sprintf "\n\nplayers: %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->send_msg (log => $msg, cf::NDI_REPLY);
};

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

cf::register_command whereabouts => sub {
   my ($ob, $arg) = @_;

   my %count;

   for my $pl (cf::player::list) {
      ++$count{$pl->ob->region->longname};
   }

   my $msg = "In the world currently there are:\n\n"
           . join "", map "$count{$_} player(s) $_\n\n", sort keys %count;

   $ob->send_msg (log => $msg, cf::NDI_REPLY);
};

cf::register_command hiscore => sub {
   my ($ob, $arg) = @_;

   my $url = $cf::CFG->{hiscore_url};
   $ob->send_msg (log => "See $url", cf::NDI_REPLY);
};

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

cf::register_command petmode => sub {
   my ($ob, $arg) = @_;

   _set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
};

cf::register_command usekeys => sub {
   my ($ob, $arg) = @_;

   _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
};

cf::register_command hintmode => sub {
   my ($ob, $arg) = @_;

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

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

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...");
};

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.");
};

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

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

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

# 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");
};

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.");
};

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
}

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"');
   }
};

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

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

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