server/ext/commands.ext

#! perl # mandatory depends=irc

use POSIX ();

# miscellaneous commands

sub who_listing(;$$) {
   my ($privileged, $select) = @_;

   my ($numwiz, $numafk) = (0, 0);
   my @pl;

   foreach my $pl (cf::player::list) {
      my $ns = $pl->ns or next;
      my $ob = $pl->ob;

      next unless $ob->map
               && ($privileged || !$pl->hidden);

      $numwiz++ if $ob->flag (cf::FLAG_WIZ);
      $numafk++ if $ns->afk;

      push @pl, $pl;
   }

   (
      "Total Players in The World. (" . (scalar @pl) . ") -- WIZ($numwiz) AFK($numafk) BOT(0)",
      (grep /$select/,
          map {
             my ($pl, $ob, $ns) = ($_, $_->ob, $_->ns);
      
             "* " . $ob->name . "/" . $ob->level . " " . (length $pl->own_title ? $pl->own_title : "the " . $pl->title)
             . ($pl->gender ? " [f]" : " [m]")
             . ($pl->peaceful ? " [peaceful]" : " [HOSTILE]")
             . ($ns->afk ? " [AFK]" : "")
             . ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "")
             . " [" . $pl->ns->{who_version} . "]"
             . " [" . ($pl->peaceful || $privileged ? $ob->map->visible_name : $ob->region->name) . "]"
             . (sprintf " [rtt %.3fs]", $pl->ns->tcpi_rtt * 1e-6)
             . ($privileged ? " " . $pl->ns->host : "")
          } sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl
      ),
      eval { "* IRC: " . join ", ", ext::irc::users },
   )
}

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

   $ob->speed_left ($ob->speed_left - 4);

   $ob->send_msg ("c/who" => (join "\r", who_listing $ob->may ("extended_who"), $arg), cf::NDI_DK_ORANGE | cf::NDI_REPLY | cf::NDI_CLEAR | cf::NDI_DEF);
};

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

   cf::async {
      if (my ($login) = $args =~ /(\S+)/) {
         if ($login eq $pl->name) {
            $pl->message ("Very funny, $login. Ha. Ha.", cf::NDI_REPLY);
         } elsif (cf::player::find_active $login) {
            $pl->message ("$login is right here on this server!", cf::NDI_REPLY);
         } elsif (cf::player::exists $login
                  and !Coro::AIO::aio_stat cf::player::path $login) {
            my $time = (stat _)[9];

            $pl->message ("$login was last seen here "
                           . (POSIX::strftime "%Y-%m-%d %H:%M:%S +0000", gmtime $time)
                           . " which was " . (int +(time - $time) / 3600) . " hours ago.", cf::NDI_REPLY);
         } else {
            $pl->message ("No player named $login is known to me.", cf::NDI_REPLY);
         }
      } else {
         $pl->message ("Usage: seen <player>", cf::NDI_REPLY);
      }
   };
};

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

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

   # Too hard to try and make a header that lines everything up, so just
   # give a description. (comment from C++)
   my $reply =
       "The first column is the name of the body location.\r"
     . "The second column is how many of those locations your body has.\r"
     . "The third column is how many slots in that location are available.\r"
     . "The last column shows the items currently using the slot\n\n";

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

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

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

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

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

#cf::register_command mark => sub {
#   my ($pl, $arg) = @_;
#
#   if (length $arg) {
#      my $ob = $pl->find_best_object_match ($arg);
#
#      return $pl->reply (undef, "Could not find an object that matches $arg")
#         unless $ob;
#
#      $pl->contr->mark ($ob);
#      $pl->reply (undef, (sprintf "Marked item %s", $ob->name, $ob->title));
#   } else {
#      my $ob = $pl->mark;
#
#      $pl->reply (undef, $ob
#         ? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
#         : "You have no marked object.");
#   }
#};

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

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

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

   my $msg = '';

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

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

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

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

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

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

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

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

   my %count;

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

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

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

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

   my $url = $cf::CFG{hiscore_url};
   $ob->send_msg (log => "See $url", cf::NDI_REPLY);
};

sub _set_mode($$$@) {
   my ($name, $ob, $arg, $slot, @choices) = @_;

   my $oldmode = $ob->contr->$slot;

   return $ob->reply (undef, "$name is set to $choices[$oldmode]")
      unless $arg;

   my ($idx) = grep $choices[$_] eq $arg, 0 .. $#choices
      or return $ob->reply (undef, "$name: Unknown options '$arg', valid options are @choices"), 1;

   $ob->contr->$slot ($idx);
   $ob->reply (undef, "$name" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $choices[$ob->contr->$slot]);
}

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

   _set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
};

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

   _set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
};

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

   _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
};

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

   _set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);
};

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

   $ob->contr->ns->afk (!(length $arg ? !$arg : $ob->contr->ns->afk));
   $ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK." : "You are no longer AFK.");
};

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

   $ob->contr->ns->bumpmsg (!(length $arg ? !$arg : $ob->contr->ns->bumpmsg));
   $ob->reply (undef, $ob->contr->ns->bumpmsg ? "Bumping into walls sounds more painful now." : "Bumping into walls will now be silent.");
};

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

   $ob->contr->braced (!(length $arg ? !$arg : $ob->contr->ns->braced));
   $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
};

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

   $ob->contr->ns->sound (!(length $arg ? !$arg : $ob->contr->ns->sound));
   $ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
};

cf::register_command 'output-rate' => sub {
   my ($ob, $arg) = @_;

   return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
      unless $arg > 0;

   $ob->contr->ns->max_rate ((cf::clamp $arg, $OUTPUT_RATE_MIN, $OUTPUT_RATE_MAX) * $TICK);
   $ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $TICK);
};

cf::register_command 'output-count' => sub {
   my ($ob, $arg) = @_;

   return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
      unless $arg > 0;

   $arg = 4 if $arg < 4;

   $ob->contr->outputs_count ($arg);
   $ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
};

cf::register_command 'output-sync' => sub {
   my ($ob, $arg) = @_;

   return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
      unless length $arg;

   $arg = 0.5 if $arg < 0.5;

   $ob->contr->outputs_sync ($arg / $cf::TICK);
   $ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
};

# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
# some other level (which may also be 0), this does not get echoed,
# but it does get set.
cf::register_command wimpy => sub {
   my ($ob, $arg) = @_;

   my $wimpy = $ob->run_away;
   return $ob->reply (undef, "Your current wimpy level is $wimpy.")
      if $arg eq "";

   return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
      if $arg =~ /^\d+$/ and $arg <= 100;

   $ob->reply (undef, "Incorrect parameters for wimpy: $arg");
};

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

   $ob->reply (undef, "You cannot change your peaceful setting with this command."
                     ." Please speak to the priest in the temple of Gorokh"
                     ." if you want to become hostile or in temple of Valriel"
                     ." if you want to become peaceful again.");

   #$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
   #$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
};

sub rename_to($$$) {
   my ($ob, $from, $to) = @_;

   $to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
      or return $ob->message ("rename: name must consist only of letters, digits, spaces and a few other things.");

   127 >= length $to
      or return $ob->message ("rename: new name must be <= 127 characters.");

   my $item;

   if (length $from) {
      $item = $ob->find_best_object_match ($from)
         or return $ob->message ("rename: could not find a matching item to rename.");
   } else {
      $item = $ob->mark
         or return $ob->message ("rename: no from name and no marked item found to rename.");
   }

  $item->custom_name (length $to ? $to : undef);

  if (length $to) {
     $item->custom_name ($to);
     $ob->message ("Your " . $item->base_name . " will now be called $to.");
  } else {
     $item->custom_name (undef);
     $ob->message ("You stop calling your " . $item->base_name . " with weird names.");
  }

  $ob->esrv_update_item (cf::UPD_NAME, $item);

  1
}

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

   $ob->speed_left ($ob->speed_left - 0.25);

   if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>]*)> \s*$/x) {
      # compatibility syntax
      rename_to $ob, $1, $2;
   } elsif ($arg =~ /
               ^\s*
               (?:
                  (?: "((?:[^"]+|\\.)*)" | (\S+) )
               \s+)?
               to \s+
               (?: "((?:[^"]+|\\.)*)" | (\S+) )
               \s*$
            /x) {
      # does not unquote $1 or $3
      rename_to $ob, $2||$1, $4||$3;
   } else {
      $ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
   }
};

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

   my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
   my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
   $ob->send_msg ("c/uptime" => "server started $startup, uptime ${runtime}\d", cf::NDI_REPLY | cf::NDI_CLEAR);
};

my %IN_MEMORY = (
   cf::MAP_ACTIVE => "I",
   cf::MAP_SWAPPED   => "S",
   cf::MAP_LOADING   => "L",
);

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

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

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

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

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

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

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

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

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

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