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 "\n\n", 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) = @_;

   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.\n\n"
     . "The second column is how many of those locations your body has.\n\n"
     . "The third column is how many slots in that location are available.\n\n";

   $reply .= sprintf " %-20s %3s %5s\n", "Location", "You", "Avail";
   for (0 .. cf::NUM_BODY_LOCATIONS - 1) {
      my $msg = cf::object::slot_nonuse_name $_;
      $msg =~ s/^.*? a //;
      $reply .= sprintf " %-20s %3d %5d\n", $msg, $ob->slot_info ($_), $ob->slot_used ($_)
         if $ob->slot_info ($_) or $ob->slot_used ($_);
   }

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

   $ob->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) %s", $map->name, $map->path, $observe->region->longname;
   $msg .= sprintf "\n\nplayers: %d difficulty: %d size: %d start: %dx%d timeout: %d",
              (scalar $map->players), $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout
      if $ob->flag (cf::FLAG_WIZ);

   $ob->send_msg ("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%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 = "In the world currently there are:\n\n"
           . join "", map "$count{$_} player(s) $_\n\n", 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_IN_MEMORY => "I",
   cf::MAP_SWAPPED   => "S",
   cf::MAP_LOADING   => "L",
);

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

   no re 'eval'; $arg = qr<$arg>;

   my $format = "%2s %1s %3s %5s %.60s\n";

   $ob->send_msg ("c/mapinfo" => (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_REPLY | cf::NDI_CLEAR);

   for (sort keys %cf::MAP) {
      my $map = $cf::MAP{$_}
         or next;

      next unless $map->path =~ $arg;
      next if $map->{deny_list};

      my $svd = int $cf::RUNTIME - $map->{last_save};
      $svd = "++" if $svd > 99;

      $ob->send_msg ("c/mapinfo" =>
                  (sprintf $format,
                   (scalar $map->players), 
                   $IN_MEMORY{$map->in_memory} || "?",
                   $svd,
                   (int $map->reset_at - $cf::RUNTIME),
                   $map->visible_name)
      );
   }
};

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