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.\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\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.71
Committed:	Tue Sep 23 00:24:52 2008 UTC (15 years, 8 months ago) by root
Branch:	MAIN
CVS Tags:	rel-2_72, rel-2_73, rel-2_71, rel-2_74, rel-2_75
Changes since 1.70:	+18 -16 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.69	. "The third column is how many slots in that location are available.\n\n";
89	pippijn	1.27
90	root	1.52	$reply .= sprintf " %-20s %3s %5s\n", "Location", "You", "Avail";
91	root	1.43	for (0 .. cf::NUM_BODY_LOCATIONS - 1) {
92	root	1.44	my $msg = cf::object::slot_nonuse_name $_;
93			$msg =~ s/^.*? a //;
94	root	1.52	$reply .= sprintf " %-20s %3d %5d\n", $msg, $ob->slot_info ($_), $ob->slot_used ($_)
95	root	1.43	if $ob->slot_info ($_) or $ob->slot_used ($_);
96	pippijn	1.27	}
97
98	root	1.68	$reply .= "You are not allowed to wear armor\r"
99	pippijn	1.27	unless $ob->flag (cf::FLAG_USE_ARMOUR);
100	root	1.68	$reply .= "You are not allowed to use weapons\r"
101	pippijn	1.27	unless $ob->flag (cf::FLAG_USE_WEAPON);
102
103	root	1.64	$ob->send_msg ("c/body" => $reply, cf::NDI_REPLY);
104	pippijn	1.27	};
105
106	pippijn	1.28	cf::register_command mark => sub {
107			my ($pl, $arg) = @_;
108
109	pippijn	1.32	if (length $arg) {
110	pippijn	1.28	my $ob = $pl->find_best_object_match ($arg);
111
112			return $pl->reply (undef, "Could not find an object that matches $arg")
113			unless $ob;
114
115	pippijn	1.29	$pl->contr->mark ($ob);
116	pippijn	1.28	$pl->reply (undef, (sprintf "Marked item %s", $ob->name, $ob->title));
117	pippijn	1.32	} else {
118			my $ob = $pl->find_marked_object;
119
120			$pl->reply (undef, $ob
121			? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
122			: "You have no marked object.");
123	pippijn	1.28	}
124			};
125
126			for my $cmd ("run", "fire") {
127			my $oncmd = "${cmd}_on";
128			cf::register_command $cmd => sub {
129			my ($ob, $arg) = @_;
130
131	pippijn	1.34	$ob->reply (undef, "Can't $cmd into a non adjacent square.")
132	pippijn	1.28	if $arg < 0 or $arg >= 9;
133
134	pippijn	1.34	$ob->contr->$oncmd (1);
135			$ob->move_player ($arg);
136	pippijn	1.28	};
137	pippijn	1.34
138	pippijn	1.28	cf::register_command "${cmd}_stop" => sub {
139			my ($ob) = @_;
140
141			$ob->contr->$oncmd (0);
142			};
143			}
144
145	pippijn	1.26	cf::register_command mapinfo => sub {
146			my ($ob) = @_;
147
148	root	1.56	my $observe = $ob->contr->observe;
149	root	1.55
150	root	1.56	my $map = $observe->map
151	pippijn	1.26	or return;
152	root	1.60
153	root	1.69	my $msg = sprintf "%s (%s)\r%s", $map->name, $map->path, $observe->region->longname;
154			$msg .= sprintf "\rplayers: %d difficulty: %d size: %d start: %dx%d timeout: %d",
155	root	1.60	(scalar $map->players), $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout
156	pippijn	1.26	if $ob->flag (cf::FLAG_WIZ);
157	root	1.62
158	root	1.64	$ob->send_msg ("c/mapinfo" => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
159	pippijn	1.26	};
160
161	pippijn	1.25	cf::register_command whereami => sub {
162			my ($ob) = @_;
163
164	root	1.50	my $reg = $ob->contr->observe->region;
165	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);
166	root	1.58	};
167
168			cf::register_command whereabouts => sub {
169			my ($ob, $arg) = @_;
170
171			my %count;
172
173			for my $pl (cf::player::list) {
174			++$count{$pl->ob->region->longname};
175			}
176
177	root	1.70	my $msg = "T<In the world currently there are:>\n\n"
178			. join "", map { sprintf " C<%3d >player(s) %s\r", $count{$_}, $_ } sort keys %count;
179	root	1.58
180	root	1.66	$ob->send_msg ("c/who" => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
181	root	1.58	};
182
183			cf::register_command hiscore => sub {
184			my ($ob, $arg) = @_;
185	pippijn	1.25
186	root	1.63	my $url = $cf::CFG{hiscore_url};
187	root	1.60	$ob->send_msg (log => "See $url", cf::NDI_REPLY);
188	pippijn	1.25	};
189
190	root	1.31	sub _set_mode($$$@) {
191			my ($name, $ob, $arg, $slot, @choices) = @_;
192	pippijn	1.23
193	root	1.31	my $oldmode = $ob->contr->$slot;
194	pippijn	1.23
195	root	1.31	return $ob->reply (undef, "$name is set to $choices[$oldmode]")
196	pippijn	1.23	unless $arg;
197
198	root	1.31	my ($idx) = grep $choices[$_] eq $arg, 0 .. $#choices
199			or return $ob->reply (undef, "$name: Unknown options '$arg', valid options are @choices"), 1;
200	pippijn	1.23
201	root	1.31	$ob->contr->$slot ($idx);
202			$ob->reply (undef, "$name" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $choices[$ob->contr->$slot]);
203			}
204
205			cf::register_command applymode => sub {
206			my ($ob, $arg) = @_;
207
208			_set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
209	pippijn	1.23	};
210
211			cf::register_command petmode => sub {
212			my ($ob, $arg) = @_;
213
214	root	1.31	_set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
215	pippijn	1.23	};
216
217	pippijn	1.21	cf::register_command usekeys => sub {
218			my ($ob, $arg) = @_;
219
220	root	1.31	_set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
221	pippijn	1.21	};
222
223	root	1.51	cf::register_command hintmode => sub {
224			my ($ob, $arg) = @_;
225
226			_set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);
227			};
228
229	pippijn	1.19	cf::register_command afk => sub {
230			my ($ob, $arg) = @_;
231
232			$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
233			$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
234			};
235
236	pippijn	1.21	cf::register_command sound => sub {
237			my ($ob, $arg) = @_;
238
239			$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
240			$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
241			};
242
243	pippijn	1.20	cf::register_command brace => sub {
244			my ($ob, $arg) = @_;
245
246			$ob->contr->braced ($ob->contr->braced ? 0 : 1);
247			$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
248			};
249
250	root	1.35	cf::register_command 'output-rate' => sub {
251			my ($ob, $arg) = @_;
252
253			return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
254			unless $arg > 0;
255
256	root	1.54	# minimum is 5k/s
257	root	1.57	# maximum is 100k/s, this should be configurable
258			$ob->contr->ns->max_rate ((List::Util::max 5000, List::Util::min 100000, $arg) * $cf::TICK);
259	root	1.36	$ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
260	root	1.35	};
261
262	pippijn	1.24	cf::register_command 'output-count' => sub {
263			my ($ob, $arg) = @_;
264
265			return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
266			unless $arg > 0;
267
268	root	1.41	$arg = 4 if $arg < 4;
269
270	pippijn	1.24	$ob->contr->outputs_count ($arg);
271			$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
272			};
273
274			cf::register_command 'output-sync' => sub {
275			my ($ob, $arg) = @_;
276
277	root	1.38	return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
278			unless length $arg;
279	pippijn	1.24
280	root	1.41	$arg = 0.5 if $arg < 0.5;
281
282	root	1.38	$ob->contr->outputs_sync ($arg / $cf::TICK);
283			$ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
284	pippijn	1.24	};
285
286	pippijn	1.20	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
287			# some other level (which may also be 0), this does not get echoed,
288			# but it does get set.
289			cf::register_command wimpy => sub {
290			my ($ob, $arg) = @_;
291
292			my $wimpy = $ob->run_away;
293			return $ob->reply (undef, "Your current wimpy level is $wimpy.")
294			if $arg eq "";
295
296			return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
297			if $arg =~ /^\d+$/ and $arg <= 100;
298
299			$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
300			};
301
302			cf::register_command peaceful => sub {
303			my ($ob, $arg) = @_;
304
305			$ob->reply (undef, "You cannot change your peaceful setting with this command."
306			." Please speak to the priest in the temple of Gorokh"
307			." if you want to become hostile or in temple of Valriel"
308			." if you want to become peaceful again.");
309
310			#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
311			#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
312	root	1.58	};
313
314			sub rename_to($$$) {
315			my ($ob, $from, $to) = @_;
316
317			$to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
318			or return $ob->message ("rename: name must consist only of letters, digits, spaces and a few other things.");
319
320			127 >= length $to
321			or return $ob->message ("rename: new name must be <= 127 characters.");
322
323			my $item;
324
325			if (length $from) {
326			$item = $ob->find_best_object_match ($from)
327			or return $ob->message ("rename: could not find a matching item to rename.");
328			} else {
329			$item = $ob->find_marked_object
330			or return $ob->message ("rename: no from name and no marked item found to rename.");
331			}
332	pippijn	1.22
333	root	1.58	$item->custom_name (length $to ? $to : undef);
334
335			if (length $to) {
336			$item->custom_name ($to);
337			$ob->message ("Your " . $item->base_name . " will now be called $to.");
338			} else {
339			$item->custom_name (undef);
340			$ob->message ("You stop calling your " . $item->base_name . " with weird names.");
341			}
342
343			$ob->esrv_update_item (cf::UPD_NAME, $item);
344
345			1
346			}
347	pippijn	1.20
348	root	1.1	cf::register_command rename => sub {
349			my ($ob, $arg) = @_;
350
351			$ob->speed_left ($ob->speed_left - 0.25);
352
353			if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>])> \s$/x) {
354			# compatibility syntax
355			rename_to $ob, $1, $2;
356			} elsif ($arg =~ /
357			^\s*
358			(?:
359			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
360			\s+)?
361			to \s+
362			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
363			\s*$
364			/x) {
365			# does not unquote $1 or $3
366			rename_to $ob, $2\|\|$1, $4\|\|$3;
367			} else {
368			$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
369			}
370			};
371
372			cf::register_command uptime => sub {
373			my ($ob, $arg) = @_;
374
375			my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
376			my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
377	root	1.65	$ob->send_msg ("c/uptime" => "server started $startup, uptime ${runtime}\d", cf::NDI_REPLY \| cf::NDI_CLEAR);
378	root	1.1	};
379
380	root	1.8	my %IN_MEMORY = (
381	root	1.67	cf::MAP_ACTIVE => "I",
382	root	1.8	cf::MAP_SWAPPED => "S",
383			cf::MAP_LOADING => "L",
384			);
385
386	root	1.7	cf::register_command maps => sub {
387			my ($ob, $arg) = @_;
388
389			no re 'eval'; $arg = qr<$arg>;
390
391	root	1.68	my $format = " %2s %1s %3s %5s %.60s\n";
392	root	1.7
393	root	1.68	my $msg = "\n" . sprintf $format, "Pl", "I", "Svd", "Reset", "Name";
394	root	1.7
395			for (sort keys %cf::MAP) {
396			my $map = $cf::MAP{$_}
397			or next;
398
399			next unless $map->path =~ $arg;
400	root	1.17	next if $map->{deny_list};
401	root	1.7
402	root	1.10	my $svd = int $cf::RUNTIME - $map->{last_save};
403			$svd = "++" if $svd > 99;
404
405	root	1.68	$msg .= sprintf $format,
406			(scalar $map->players),
407			$IN_MEMORY{$map->in_memory} \|\| "?",
408			$svd,
409			(int $map->reset_at - $cf::RUNTIME),
410			$map->visible_name;
411	root	1.7	}
412	root	1.68
413			$ob->send_msg ("c/mapinfo" => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
414	root	1.7	};
415