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 ("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) = @_;

   # 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), $ob->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,
                        $ob->slot_info ($_),
                        $ob->slot_used ($_),
                        join ", ", map $_->query_short_name, @{ $slot[$_] }
        if $ob->slot_info ($_) || $ob->slot_used ($_);
   }

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

   $ob->send_msg ("c/body" => $reply, cf::NDI_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)\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;

   # 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->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.72
Committed:	Sun Jan 11 06:08:40 2009 UTC (15 years, 4 months ago) by root
Branch:	MAIN
CVS Tags:	rel-2_80, rel-2_76, rel-2_77, rel-2_79, rel-2_78
Changes since 1.71:	+18 -4 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.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			# Too hard to try and make a header that lines everything up, so just
84			# give a description. (comment from C++)
85	root	1.44	my $reply =
86	root	1.68	"The first column is the name of the body location.\r"
87			. "The second column is how many of those locations your body has.\r"
88	root	1.72	. "The third column is how many slots in that location are available.\r"
89			. "The last column shows the items currently using the slot\n\n";
90	pippijn	1.27
91	root	1.72	# first process all applied items and hash them into their slots
92			my @slot;
93
94			for my $item (grep $_->flag (cf::FLAG_APPLIED), $ob->inv) {
95			$item->slot_info ($_)
96			and push @{ $slot[$_] }, $item
97			for 0 .. cf::NUM_BODY_LOCATIONS-1;
98			}
99
100			$reply .= sprintf " %-20s %3s %5s %s\n", "Location", "You", "Avail", "What";
101	root	1.43	for (0 .. cf::NUM_BODY_LOCATIONS - 1) {
102	root	1.44	my $msg = cf::object::slot_nonuse_name $_;
103			$msg =~ s/^.*? a //;
104	root	1.72	$reply .= sprintf " %-20s %3d %5d %s\n",
105			$msg,
106			$ob->slot_info ($_),
107			$ob->slot_used ($_),
108			join ", ", map $_->query_short_name, @{ $slot[$_] }
109			if $ob->slot_info ($_) \|\| $ob->slot_used ($_);
110	pippijn	1.27	}
111
112	root	1.68	$reply .= "You are not allowed to wear armor\r"
113	pippijn	1.27	unless $ob->flag (cf::FLAG_USE_ARMOUR);
114	root	1.68	$reply .= "You are not allowed to use weapons\r"
115	pippijn	1.27	unless $ob->flag (cf::FLAG_USE_WEAPON);
116
117	root	1.64	$ob->send_msg ("c/body" => $reply, cf::NDI_REPLY);
118	pippijn	1.27	};
119
120	pippijn	1.28	cf::register_command mark => sub {
121			my ($pl, $arg) = @_;
122
123	pippijn	1.32	if (length $arg) {
124	pippijn	1.28	my $ob = $pl->find_best_object_match ($arg);
125
126			return $pl->reply (undef, "Could not find an object that matches $arg")
127			unless $ob;
128
129	pippijn	1.29	$pl->contr->mark ($ob);
130	pippijn	1.28	$pl->reply (undef, (sprintf "Marked item %s", $ob->name, $ob->title));
131	pippijn	1.32	} else {
132			my $ob = $pl->find_marked_object;
133
134			$pl->reply (undef, $ob
135			? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
136			: "You have no marked object.");
137	pippijn	1.28	}
138			};
139
140			for my $cmd ("run", "fire") {
141			my $oncmd = "${cmd}_on";
142			cf::register_command $cmd => sub {
143			my ($ob, $arg) = @_;
144
145	pippijn	1.34	$ob->reply (undef, "Can't $cmd into a non adjacent square.")
146	pippijn	1.28	if $arg < 0 or $arg >= 9;
147
148	pippijn	1.34	$ob->contr->$oncmd (1);
149			$ob->move_player ($arg);
150	pippijn	1.28	};
151	pippijn	1.34
152	pippijn	1.28	cf::register_command "${cmd}_stop" => sub {
153			my ($ob) = @_;
154
155			$ob->contr->$oncmd (0);
156			};
157			}
158
159	pippijn	1.26	cf::register_command mapinfo => sub {
160			my ($ob) = @_;
161
162	root	1.56	my $observe = $ob->contr->observe;
163	root	1.55
164	root	1.56	my $map = $observe->map
165	pippijn	1.26	or return;
166	root	1.60
167	root	1.69	my $msg = sprintf "%s (%s)\r%s", $map->name, $map->path, $observe->region->longname;
168			$msg .= sprintf "\rplayers: %d difficulty: %d size: %d start: %dx%d timeout: %d",
169	root	1.60	(scalar $map->players), $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout
170	pippijn	1.26	if $ob->flag (cf::FLAG_WIZ);
171	root	1.62
172	root	1.64	$ob->send_msg ("c/mapinfo" => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
173	pippijn	1.26	};
174
175	pippijn	1.25	cf::register_command whereami => sub {
176			my ($ob) = @_;
177
178	root	1.50	my $reg = $ob->contr->observe->region;
179	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);
180	root	1.58	};
181
182			cf::register_command whereabouts => sub {
183			my ($ob, $arg) = @_;
184
185			my %count;
186
187			for my $pl (cf::player::list) {
188			++$count{$pl->ob->region->longname};
189			}
190
191	root	1.70	my $msg = "T<In the world currently there are:>\n\n"
192			. join "", map { sprintf " C<%3d >player(s) %s\r", $count{$_}, $_ } sort keys %count;
193	root	1.58
194	root	1.66	$ob->send_msg ("c/who" => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
195	root	1.58	};
196
197			cf::register_command hiscore => sub {
198			my ($ob, $arg) = @_;
199	pippijn	1.25
200	root	1.63	my $url = $cf::CFG{hiscore_url};
201	root	1.60	$ob->send_msg (log => "See $url", cf::NDI_REPLY);
202	pippijn	1.25	};
203
204	root	1.31	sub _set_mode($$$@) {
205			my ($name, $ob, $arg, $slot, @choices) = @_;
206	pippijn	1.23
207	root	1.31	my $oldmode = $ob->contr->$slot;
208	pippijn	1.23
209	root	1.31	return $ob->reply (undef, "$name is set to $choices[$oldmode]")
210	pippijn	1.23	unless $arg;
211
212	root	1.31	my ($idx) = grep $choices[$_] eq $arg, 0 .. $#choices
213			or return $ob->reply (undef, "$name: Unknown options '$arg', valid options are @choices"), 1;
214	pippijn	1.23
215	root	1.31	$ob->contr->$slot ($idx);
216			$ob->reply (undef, "$name" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $choices[$ob->contr->$slot]);
217			}
218
219			cf::register_command applymode => sub {
220			my ($ob, $arg) = @_;
221
222			_set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
223	pippijn	1.23	};
224
225			cf::register_command petmode => sub {
226			my ($ob, $arg) = @_;
227
228	root	1.31	_set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
229	pippijn	1.23	};
230
231	pippijn	1.21	cf::register_command usekeys => sub {
232			my ($ob, $arg) = @_;
233
234	root	1.31	_set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
235	pippijn	1.21	};
236
237	root	1.51	cf::register_command hintmode => sub {
238			my ($ob, $arg) = @_;
239
240			_set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);
241			};
242
243	pippijn	1.19	cf::register_command afk => sub {
244			my ($ob, $arg) = @_;
245
246			$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
247			$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
248			};
249
250	pippijn	1.21	cf::register_command sound => sub {
251			my ($ob, $arg) = @_;
252
253			$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
254			$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
255			};
256
257	pippijn	1.20	cf::register_command brace => sub {
258			my ($ob, $arg) = @_;
259
260			$ob->contr->braced ($ob->contr->braced ? 0 : 1);
261			$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
262			};
263
264	root	1.35	cf::register_command 'output-rate' => sub {
265			my ($ob, $arg) = @_;
266
267			return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
268			unless $arg > 0;
269
270	root	1.54	# minimum is 5k/s
271	root	1.57	# maximum is 100k/s, this should be configurable
272			$ob->contr->ns->max_rate ((List::Util::max 5000, List::Util::min 100000, $arg) * $cf::TICK);
273	root	1.36	$ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::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			$item = $ob->find_marked_object
344			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