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 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->find_marked_object;
#
#      $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 = sprintf "%s (%s)\r%s", $map->name, $map->path, $observe->region->longname;
   $msg .= sprintf "\rplayers: %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 ("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->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->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.76
Committed:	Mon Apr 12 05:22:37 2010 UTC (14 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.75:	+2 -4 lines
Log Message:	freelist management
#	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			and stat cf::player::path $login) {
66			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			# my $ob = $pl->find_marked_object;
135			#
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	root	1.69	my $msg = sprintf "%s (%s)\r%s", $map->name, $map->path, $observe->region->longname;
151			$msg .= sprintf "\rplayers: %d difficulty: %d size: %d start: %dx%d timeout: %d",
152	root	1.60	(scalar $map->players), $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout
153	pippijn	1.26	if $ob->flag (cf::FLAG_WIZ);
154	root	1.62
155	root	1.64	$ob->send_msg ("c/mapinfo" => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
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	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);
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	root	1.70	my $msg = "T<In the world currently there are:>\n\n"
175			. join "", map { sprintf " C<%3d >player(s) %s\r", $count{$_}, $_ } sort keys %count;
176	root	1.58
177	root	1.66	$ob->send_msg ("c/who" => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
178	root	1.58	};
179
180			cf::register_command hiscore => sub {
181			my ($ob, $arg) = @_;
182	pippijn	1.25
183	root	1.63	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.76	$ob->contr->ns->max_rate ((cf::clamp $arg, $OUTPUT_RATE_MIN, $OUTPUT_RATE_MAX) * $TICK);
254			$ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $TICK);
255	root	1.35	};
256
257	pippijn	1.24	cf::register_command 'output-count' => sub {
258			my ($ob, $arg) = @_;
259
260			return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
261			unless $arg > 0;
262
263	root	1.41	$arg = 4 if $arg < 4;
264
265	pippijn	1.24	$ob->contr->outputs_count ($arg);
266			$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
267			};
268
269			cf::register_command 'output-sync' => sub {
270			my ($ob, $arg) = @_;
271
272	root	1.38	return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
273			unless length $arg;
274	pippijn	1.24
275	root	1.41	$arg = 0.5 if $arg < 0.5;
276
277	root	1.38	$ob->contr->outputs_sync ($arg / $cf::TICK);
278			$ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
279	pippijn	1.24	};
280
281	pippijn	1.20	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
282			# some other level (which may also be 0), this does not get echoed,
283			# but it does get set.
284			cf::register_command wimpy => sub {
285			my ($ob, $arg) = @_;
286
287			my $wimpy = $ob->run_away;
288			return $ob->reply (undef, "Your current wimpy level is $wimpy.")
289			if $arg eq "";
290
291			return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
292			if $arg =~ /^\d+$/ and $arg <= 100;
293
294			$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
295			};
296
297			cf::register_command peaceful => sub {
298			my ($ob, $arg) = @_;
299
300			$ob->reply (undef, "You cannot change your peaceful setting with this command."
301			." Please speak to the priest in the temple of Gorokh"
302			." if you want to become hostile or in temple of Valriel"
303			." if you want to become peaceful again.");
304
305			#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
306			#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
307	root	1.58	};
308
309			sub rename_to($$$) {
310			my ($ob, $from, $to) = @_;
311
312			$to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
313			or return $ob->message ("rename: name must consist only of letters, digits, spaces and a few other things.");
314
315			127 >= length $to
316			or return $ob->message ("rename: new name must be <= 127 characters.");
317
318			my $item;
319
320			if (length $from) {
321			$item = $ob->find_best_object_match ($from)
322			or return $ob->message ("rename: could not find a matching item to rename.");
323			} else {
324			$item = $ob->find_marked_object
325			or return $ob->message ("rename: no from name and no marked item found to rename.");
326			}
327	pippijn	1.22
328	root	1.58	$item->custom_name (length $to ? $to : undef);
329
330			if (length $to) {
331			$item->custom_name ($to);
332			$ob->message ("Your " . $item->base_name . " will now be called $to.");
333			} else {
334			$item->custom_name (undef);
335			$ob->message ("You stop calling your " . $item->base_name . " with weird names.");
336			}
337
338			$ob->esrv_update_item (cf::UPD_NAME, $item);
339
340			1
341			}
342	pippijn	1.20
343	root	1.1	cf::register_command rename => sub {
344			my ($ob, $arg) = @_;
345
346			$ob->speed_left ($ob->speed_left - 0.25);
347
348			if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>])> \s$/x) {
349			# compatibility syntax
350			rename_to $ob, $1, $2;
351			} elsif ($arg =~ /
352			^\s*
353			(?:
354			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
355			\s+)?
356			to \s+
357			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
358			\s*$
359			/x) {
360			# does not unquote $1 or $3
361			rename_to $ob, $2\|\|$1, $4\|\|$3;
362			} else {
363			$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
364			}
365			};
366
367			cf::register_command uptime => sub {
368			my ($ob, $arg) = @_;
369
370			my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
371			my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
372	root	1.65	$ob->send_msg ("c/uptime" => "server started $startup, uptime ${runtime}\d", cf::NDI_REPLY \| cf::NDI_CLEAR);
373	root	1.1	};
374
375	root	1.8	my %IN_MEMORY = (
376	root	1.67	cf::MAP_ACTIVE => "I",
377	root	1.8	cf::MAP_SWAPPED => "S",
378			cf::MAP_LOADING => "L",
379			);
380
381	root	1.7	cf::register_command maps => sub {
382			my ($ob, $arg) = @_;
383
384			no re 'eval'; $arg = qr<$arg>;
385
386	root	1.68	my $format = " %2s %1s %3s %5s %.60s\n";
387	root	1.7
388	root	1.68	my $msg = "\n" . sprintf $format, "Pl", "I", "Svd", "Reset", "Name";
389	root	1.7
390			for (sort keys %cf::MAP) {
391			my $map = $cf::MAP{$_}
392			or next;
393
394			next unless $map->path =~ $arg;
395	root	1.17	next if $map->{deny_list};
396	root	1.7
397	root	1.10	my $svd = int $cf::RUNTIME - $map->{last_save};
398			$svd = "++" if $svd > 99;
399
400	root	1.68	$msg .= sprintf $format,
401			(scalar $map->players),
402			$IN_MEMORY{$map->in_memory} \|\| "?",
403			$svd,
404			(int $map->reset_at - $cf::RUNTIME),
405			$map->visible_name;
406	root	1.7	}
407	root	1.68
408			$ob->send_msg ("c/mapinfo" => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
409	root	1.7	};
410