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->{who_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 ("c/who" => (join "\r", who_listing $ob->may ("extended_who"), $arg), cf::NDI_DK_ORANGE | cf::NDI_REPLY | cf::NDI_CLEAR | cf::NDI_DEF);
};

cf::register_command seen => sub {
   my ($pl, $args) = @_;

   cf::async {
      if (my ($login) = $args =~ /(\S+)/) {
         if ($login eq $pl->name) {
            $pl->message ("Very funny, $login. Ha. Ha.", cf::NDI_REPLY);
         } elsif (cf::player::find_active $login) {
            $pl->message ("$login is right here on this server!", cf::NDI_REPLY);
         } elsif (cf::player::exists $login
                  and !Coro::AIO::aio_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_REPLY);
         } else {
            $pl->message ("No player named $login is known to me.", cf::NDI_REPLY);
         }
      } else {
         $pl->message ("Usage: seen <player>", cf::NDI_REPLY);
      }
   };
};

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

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

   # 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.\r"
     . "The second column is how many of those locations your body has.\r"
     . "The third column is how many slots in that location are available.\r"
     . "The last column shows the items currently using the slot\n\n";

   # first process all applied items and hash them into their slots
   my @slot;

   for my $item (grep $_->flag (cf::FLAG_APPLIED), $observe->inv) {
      $item->slot_info ($_)
         and push @{ $slot[$_] }, $item
            for 0 .. cf::NUM_BODY_LOCATIONS-1;
   }

   $reply .= sprintf " %-20s %3s %5s %s\n", "Location", "You", "Avail", "What";
   for (0 .. cf::NUM_BODY_LOCATIONS - 1) {
      my $msg = cf::object::slot_nonuse_name $_;
      $msg =~ s/^.*? a //;
      $reply .= sprintf " %-20s %3d %5d %s\n",
                        $msg,
                        $observe->slot_info ($_),
                        $observe->slot_used ($_),
                        join ", ", map $_->query_short_name, @{ $slot[$_] }
        if $observe->slot_info ($_) || $observe->slot_used ($_);
   }

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

   $ob->send_msg ("c/body" => $reply, cf::NDI_REPLY | cf::NDI_CLEAR);
};

#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->mark;
#
#      $pl->reply (undef, $ob
#         ? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
#         : "You have no marked object.");
#   }
#};

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

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

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

   my $msg = '';

   if ($map->name ne '') {
      $msg .= sprintf "%s [%s] ", $map->name, $map->visible_name
   } else {
      $msg .= sprintf "%s ", $map->visible_name
   }

   if ($map->visible_name ne $map->path) {
      $msg .= sprintf "(%s) ", $map->path;
   }

   $msg .= sprintf "\r%s", $observe->region->longname;

   $msg .= sprintf "\rplayers: %d difficulty: %d"
                   . "\rsize: %dx%d start: %dx%d position: (%d|%d) timeout: %d",
              (scalar $map->players),
              $map->difficulty,
              $map->width, $map->height,
              $map->enter_x, $map->enter_y,
              $ob->x, $ob->y,
              $map->timeout
      if $ob->flag (cf::FLAG_WIZ);

   $ob->send_msg ("c/mapinfo" => $msg, cf::NDI_REPLY | cf::NDI_CLEAR);
};

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

   my $reg = $ob->contr->observe->region;
   $ob->send_msg ("c/who" => (sprintf "You are %s.\n\n%s", $reg->longname, $reg->msg), cf::NDI_REPLY | cf::NDI_CLEAR);
};

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

   my %count;

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

   my $msg = "T<In the world currently there are:>\n\n"
           . join "", map { sprintf " C<%3d >player(s) %s\r", $count{$_}, $_ } sort keys %count;

   $ob->send_msg ("c/who" => $msg, cf::NDI_REPLY | cf::NDI_CLEAR);
};

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;

   $ob->contr->ns->max_rate ((cf::clamp $arg, $OUTPUT_RATE_MIN, $OUTPUT_RATE_MAX) * $TICK);
   $ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $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->mark
         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->send_msg ("c/uptime" => "server started $startup, uptime ${runtime}\d", cf::NDI_REPLY | cf::NDI_CLEAR);
};

my %IN_MEMORY = (
   cf::MAP_ACTIVE => "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";

   my $msg = "\n" . sprintf $format, "Pl", "I", "Svd", "Reset", "Name";

   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;

      $msg .= sprintf $format,
                 (scalar $map->players), 
                 $IN_MEMORY{$map->in_memory} || "?",
                 $svd,
                 (int $map->reset_at - $cf::RUNTIME),
                 $map->visible_name;
   }

   $ob->send_msg ("c/mapinfo" => $msg, cf::NDI_REPLY | cf::NDI_CLEAR);
};

Revision:	1.79
Committed:	Fri May 7 19:46:18 2010 UTC (14 years ago) by root
Branch:	MAIN
CVS Tags:	rel-3_0
Changes since 1.78:	+1 -1 lines
Log Message:	seen freeze
#	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	root	1.75	. " [" . $pl->ns->{who_version} . "]"
38	root	1.42	. " [" . ($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.68	$ob->send_msg ("c/who" => (join "\r", who_listing $ob->may ("extended_who"), $arg), cf::NDI_DK_ORANGE \| cf::NDI_REPLY \| cf::NDI_CLEAR \| cf::NDI_DEF);
53	root	1.1	};
54
55	root	1.40	cf::register_command seen => sub {
56			my ($pl, $args) = @_;
57
58	root	1.71	cf::async {
59			if (my ($login) = $args =~ /(\S+)/) {
60			if ($login eq $pl->name) {
61			$pl->message ("Very funny, $login. Ha. Ha.", cf::NDI_REPLY);
62			} elsif (cf::player::find_active $login) {
63			$pl->message ("$login is right here on this server!", cf::NDI_REPLY);
64			} elsif (cf::player::exists $login
65	root	1.79	and !Coro::AIO::aio_stat cf::player::path $login) {
66	root	1.71	my $time = (stat _)[9];
67
68			$pl->message ("$login was last seen here "
69			. (POSIX::strftime "%Y-%m-%d %H:%M:%S +0000", gmtime $time)
70			. " which was " . (int +(time - $time) / 3600) . " hours ago.", cf::NDI_REPLY);
71			} else {
72			$pl->message ("No player named $login is known to me.", cf::NDI_REPLY);
73			}
74	root	1.40	} else {
75	root	1.71	$pl->message ("Usage: seen <player>", cf::NDI_REPLY);
76	root	1.40	}
77	root	1.71	};
78	root	1.40	};
79
80	pippijn	1.27	cf::register_command body => sub {
81			my ($ob) = @_;
82
83	root	1.73	my $observe = $ob->contr->observe;
84
85	pippijn	1.27	# Too hard to try and make a header that lines everything up, so just
86			# give a description. (comment from C++)
87	root	1.44	my $reply =
88	root	1.68	"The first column is the name of the body location.\r"
89			. "The second column is how many of those locations your body has.\r"
90	root	1.72	. "The third column is how many slots in that location are available.\r"
91			. "The last column shows the items currently using the slot\n\n";
92	pippijn	1.27
93	root	1.72	# first process all applied items and hash them into their slots
94			my @slot;
95
96	root	1.73	for my $item (grep $_->flag (cf::FLAG_APPLIED), $observe->inv) {
97	root	1.72	$item->slot_info ($_)
98			and push @{ $slot[$_] }, $item
99			for 0 .. cf::NUM_BODY_LOCATIONS-1;
100			}
101
102			$reply .= sprintf " %-20s %3s %5s %s\n", "Location", "You", "Avail", "What";
103	root	1.43	for (0 .. cf::NUM_BODY_LOCATIONS - 1) {
104	root	1.44	my $msg = cf::object::slot_nonuse_name $_;
105			$msg =~ s/^.*? a //;
106	root	1.72	$reply .= sprintf " %-20s %3d %5d %s\n",
107			$msg,
108	root	1.73	$observe->slot_info ($_),
109			$observe->slot_used ($_),
110	root	1.72	join ", ", map $_->query_short_name, @{ $slot[$_] }
111	root	1.73	if $observe->slot_info ($_) \|\| $observe->slot_used ($_);
112	pippijn	1.27	}
113
114	root	1.68	$reply .= "You are not allowed to wear armor\r"
115	root	1.73	unless $observe->flag (cf::FLAG_USE_ARMOUR);
116	root	1.68	$reply .= "You are not allowed to use weapons\r"
117	root	1.73	unless $observe->flag (cf::FLAG_USE_WEAPON);
118	pippijn	1.27
119	root	1.73	$ob->send_msg ("c/body" => $reply, cf::NDI_REPLY \| cf::NDI_CLEAR);
120	pippijn	1.27	};
121
122	root	1.74	#cf::register_command mark => sub {
123			# my ($pl, $arg) = @_;
124			#
125			# if (length $arg) {
126			# my $ob = $pl->find_best_object_match ($arg);
127			#
128			# return $pl->reply (undef, "Could not find an object that matches $arg")
129			# unless $ob;
130			#
131			# $pl->contr->mark ($ob);
132			# $pl->reply (undef, (sprintf "Marked item %s", $ob->name, $ob->title));
133			# } else {
134	root	1.78	# my $ob = $pl->mark;
135	root	1.74	#
136			# $pl->reply (undef, $ob
137			# ? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
138			# : "You have no marked object.");
139			# }
140			#};
141	pippijn	1.28
142	pippijn	1.26	cf::register_command mapinfo => sub {
143			my ($ob) = @_;
144
145	root	1.56	my $observe = $ob->contr->observe;
146	root	1.55
147	root	1.56	my $map = $observe->map
148	pippijn	1.26	or return;
149	root	1.60
150	elmex	1.77	my $msg = '';
151
152			if ($map->name ne '') {
153			$msg .= sprintf "%s [%s] ", $map->name, $map->visible_name
154			} else {
155			$msg .= sprintf "%s ", $map->visible_name
156			}
157
158			if ($map->visible_name ne $map->path) {
159			$msg .= sprintf "(%s) ", $map->path;
160			}
161
162			$msg .= sprintf "\r%s", $observe->region->longname;
163
164			$msg .= sprintf "\rplayers: %d difficulty: %d"
165			. "\rsize: %dx%d start: %dx%d position: (%d\|%d) timeout: %d",
166			(scalar $map->players),
167			$map->difficulty,
168			$map->width, $map->height,
169			$map->enter_x, $map->enter_y,
170			$ob->x, $ob->y,
171			$map->timeout
172	pippijn	1.26	if $ob->flag (cf::FLAG_WIZ);
173	root	1.62
174	root	1.64	$ob->send_msg ("c/mapinfo" => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
175	pippijn	1.26	};
176
177	pippijn	1.25	cf::register_command whereami => sub {
178			my ($ob) = @_;
179
180	root	1.50	my $reg = $ob->contr->observe->region;
181	root	1.69	$ob->send_msg ("c/who" => (sprintf "You are %s.\n\n%s", $reg->longname, $reg->msg), cf::NDI_REPLY \| cf::NDI_CLEAR);
182	root	1.58	};
183
184			cf::register_command whereabouts => sub {
185			my ($ob, $arg) = @_;
186
187			my %count;
188
189			for my $pl (cf::player::list) {
190			++$count{$pl->ob->region->longname};
191			}
192
193	root	1.70	my $msg = "T<In the world currently there are:>\n\n"
194			. join "", map { sprintf " C<%3d >player(s) %s\r", $count{$_}, $_ } sort keys %count;
195	root	1.58
196	root	1.66	$ob->send_msg ("c/who" => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
197	root	1.58	};
198
199			cf::register_command hiscore => sub {
200			my ($ob, $arg) = @_;
201	pippijn	1.25
202	root	1.63	my $url = $cf::CFG{hiscore_url};
203	root	1.60	$ob->send_msg (log => "See $url", cf::NDI_REPLY);
204	pippijn	1.25	};
205
206	root	1.31	sub _set_mode($$$@) {
207			my ($name, $ob, $arg, $slot, @choices) = @_;
208	pippijn	1.23
209	root	1.31	my $oldmode = $ob->contr->$slot;
210	pippijn	1.23
211	root	1.31	return $ob->reply (undef, "$name is set to $choices[$oldmode]")
212	pippijn	1.23	unless $arg;
213
214	root	1.31	my ($idx) = grep $choices[$_] eq $arg, 0 .. $#choices
215			or return $ob->reply (undef, "$name: Unknown options '$arg', valid options are @choices"), 1;
216	pippijn	1.23
217	root	1.31	$ob->contr->$slot ($idx);
218			$ob->reply (undef, "$name" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $choices[$ob->contr->$slot]);
219			}
220
221			cf::register_command applymode => sub {
222			my ($ob, $arg) = @_;
223
224			_set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
225	pippijn	1.23	};
226
227			cf::register_command petmode => sub {
228			my ($ob, $arg) = @_;
229
230	root	1.31	_set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
231	pippijn	1.23	};
232
233	pippijn	1.21	cf::register_command usekeys => sub {
234			my ($ob, $arg) = @_;
235
236	root	1.31	_set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
237	pippijn	1.21	};
238
239	root	1.51	cf::register_command hintmode => sub {
240			my ($ob, $arg) = @_;
241
242			_set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);
243			};
244
245	pippijn	1.19	cf::register_command afk => sub {
246			my ($ob, $arg) = @_;
247
248			$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
249			$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
250			};
251
252	pippijn	1.21	cf::register_command sound => sub {
253			my ($ob, $arg) = @_;
254
255			$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
256			$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
257			};
258
259	pippijn	1.20	cf::register_command brace => sub {
260			my ($ob, $arg) = @_;
261
262			$ob->contr->braced ($ob->contr->braced ? 0 : 1);
263			$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
264			};
265
266	root	1.35	cf::register_command 'output-rate' => sub {
267			my ($ob, $arg) = @_;
268
269			return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
270			unless $arg > 0;
271
272	root	1.76	$ob->contr->ns->max_rate ((cf::clamp $arg, $OUTPUT_RATE_MIN, $OUTPUT_RATE_MAX) * $TICK);
273			$ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $TICK);
274	root	1.35	};
275
276	pippijn	1.24	cf::register_command 'output-count' => sub {
277			my ($ob, $arg) = @_;
278
279			return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
280			unless $arg > 0;
281
282	root	1.41	$arg = 4 if $arg < 4;
283
284	pippijn	1.24	$ob->contr->outputs_count ($arg);
285			$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
286			};
287
288			cf::register_command 'output-sync' => sub {
289			my ($ob, $arg) = @_;
290
291	root	1.38	return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
292			unless length $arg;
293	pippijn	1.24
294	root	1.41	$arg = 0.5 if $arg < 0.5;
295
296	root	1.38	$ob->contr->outputs_sync ($arg / $cf::TICK);
297			$ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
298	pippijn	1.24	};
299
300	pippijn	1.20	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
301			# some other level (which may also be 0), this does not get echoed,
302			# but it does get set.
303			cf::register_command wimpy => sub {
304			my ($ob, $arg) = @_;
305
306			my $wimpy = $ob->run_away;
307			return $ob->reply (undef, "Your current wimpy level is $wimpy.")
308			if $arg eq "";
309
310			return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
311			if $arg =~ /^\d+$/ and $arg <= 100;
312
313			$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
314			};
315
316			cf::register_command peaceful => sub {
317			my ($ob, $arg) = @_;
318
319			$ob->reply (undef, "You cannot change your peaceful setting with this command."
320			." Please speak to the priest in the temple of Gorokh"
321			." if you want to become hostile or in temple of Valriel"
322			." if you want to become peaceful again.");
323
324			#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
325			#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
326	root	1.58	};
327
328			sub rename_to($$$) {
329			my ($ob, $from, $to) = @_;
330
331			$to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
332			or return $ob->message ("rename: name must consist only of letters, digits, spaces and a few other things.");
333
334			127 >= length $to
335			or return $ob->message ("rename: new name must be <= 127 characters.");
336
337			my $item;
338
339			if (length $from) {
340			$item = $ob->find_best_object_match ($from)
341			or return $ob->message ("rename: could not find a matching item to rename.");
342			} else {
343	root	1.78	$item = $ob->mark
344	root	1.58	or return $ob->message ("rename: no from name and no marked item found to rename.");
345			}
346	pippijn	1.22
347	root	1.58	$item->custom_name (length $to ? $to : undef);
348
349			if (length $to) {
350			$item->custom_name ($to);
351			$ob->message ("Your " . $item->base_name . " will now be called $to.");
352			} else {
353			$item->custom_name (undef);
354			$ob->message ("You stop calling your " . $item->base_name . " with weird names.");
355			}
356
357			$ob->esrv_update_item (cf::UPD_NAME, $item);
358
359			1
360			}
361	pippijn	1.20
362	root	1.1	cf::register_command rename => sub {
363			my ($ob, $arg) = @_;
364
365			$ob->speed_left ($ob->speed_left - 0.25);
366
367			if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>])> \s$/x) {
368			# compatibility syntax
369			rename_to $ob, $1, $2;
370			} elsif ($arg =~ /
371			^\s*
372			(?:
373			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
374			\s+)?
375			to \s+
376			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
377			\s*$
378			/x) {
379			# does not unquote $1 or $3
380			rename_to $ob, $2\|\|$1, $4\|\|$3;
381			} else {
382			$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
383			}
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	root	1.65	$ob->send_msg ("c/uptime" => "server started $startup, uptime ${runtime}\d", cf::NDI_REPLY \| cf::NDI_CLEAR);
392	root	1.1	};
393
394	root	1.8	my %IN_MEMORY = (
395	root	1.67	cf::MAP_ACTIVE => "I",
396	root	1.8	cf::MAP_SWAPPED => "S",
397			cf::MAP_LOADING => "L",
398			);
399
400	root	1.7	cf::register_command maps => sub {
401			my ($ob, $arg) = @_;
402
403			no re 'eval'; $arg = qr<$arg>;
404
405	root	1.68	my $format = " %2s %1s %3s %5s %.60s\n";
406	root	1.7
407	root	1.68	my $msg = "\n" . sprintf $format, "Pl", "I", "Svd", "Reset", "Name";
408	root	1.7
409			for (sort keys %cf::MAP) {
410			my $map = $cf::MAP{$_}
411			or next;
412
413			next unless $map->path =~ $arg;
414	root	1.17	next if $map->{deny_list};
415	root	1.7
416	root	1.10	my $svd = int $cf::RUNTIME - $map->{last_save};
417			$svd = "++" if $svd > 99;
418
419	root	1.68	$msg .= sprintf $format,
420			(scalar $map->players),
421			$IN_MEMORY{$map->in_memory} \|\| "?",
422			$svd,
423			(int $map->reset_at - $cf::RUNTIME),
424			$map->visible_name;
425	root	1.7	}
426	root	1.68
427			$ob->send_msg ("c/mapinfo" => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
428	root	1.7	};
429