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

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

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

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

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

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

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

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

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

   if (length $arg) {
      my $ob = $pl->find_best_object_match ($arg);

      return $pl->reply (undef, "Could not find an object that matches $arg")
         unless $ob;

      $pl->contr->mark ($ob);
      $pl->reply (undef, (sprintf "Marked item %s", $ob->name, $ob->title));
   } else {
      my $ob = $pl->find_marked_object;

      $pl->reply (undef, $ob
         ? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
         : "You have no marked object.");
   }
};

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.73
Committed:	Sat Oct 3 22:36:08 2009 UTC (14 years, 7 months ago) by root
Branch:	MAIN
CVS Tags:	rel-2_82, rel-2_81, rel-2_90, rel-2_92, rel-2_93
Changes since 1.72:	+9 -7 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	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	pippijn	1.28	cf::register_command mark => sub {
123			my ($pl, $arg) = @_;
124
125	pippijn	1.32	if (length $arg) {
126	pippijn	1.28	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	pippijn	1.29	$pl->contr->mark ($ob);
132	pippijn	1.28	$pl->reply (undef, (sprintf "Marked item %s", $ob->name, $ob->title));
133	pippijn	1.32	} else {
134			my $ob = $pl->find_marked_object;
135
136			$pl->reply (undef, $ob
137			? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
138			: "You have no marked object.");
139	pippijn	1.28	}
140			};
141
142			for my $cmd ("run", "fire") {
143			my $oncmd = "${cmd}_on";
144			cf::register_command $cmd => sub {
145			my ($ob, $arg) = @_;
146
147	pippijn	1.34	$ob->reply (undef, "Can't $cmd into a non adjacent square.")
148	pippijn	1.28	if $arg < 0 or $arg >= 9;
149
150	pippijn	1.34	$ob->contr->$oncmd (1);
151			$ob->move_player ($arg);
152	pippijn	1.28	};
153	pippijn	1.34
154	pippijn	1.28	cf::register_command "${cmd}_stop" => sub {
155			my ($ob) = @_;
156
157			$ob->contr->$oncmd (0);
158			};
159			}
160
161	pippijn	1.26	cf::register_command mapinfo => sub {
162			my ($ob) = @_;
163
164	root	1.56	my $observe = $ob->contr->observe;
165	root	1.55
166	root	1.56	my $map = $observe->map
167	pippijn	1.26	or return;
168	root	1.60
169	root	1.69	my $msg = sprintf "%s (%s)\r%s", $map->name, $map->path, $observe->region->longname;
170			$msg .= sprintf "\rplayers: %d difficulty: %d size: %d start: %dx%d timeout: %d",
171	root	1.60	(scalar $map->players), $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $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			$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
249			$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
250			};
251
252	pippijn	1.21	cf::register_command sound => sub {
253			my ($ob, $arg) = @_;
254
255			$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
256			$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
257			};
258
259	pippijn	1.20	cf::register_command brace => sub {
260			my ($ob, $arg) = @_;
261
262			$ob->contr->braced ($ob->contr->braced ? 0 : 1);
263			$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
264			};
265
266	root	1.35	cf::register_command 'output-rate' => sub {
267			my ($ob, $arg) = @_;
268
269			return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
270			unless $arg > 0;
271
272	root	1.54	# minimum is 5k/s
273	root	1.57	# maximum is 100k/s, this should be configurable
274			$ob->contr->ns->max_rate ((List::Util::max 5000, List::Util::min 100000, $arg) * $cf::TICK);
275	root	1.36	$ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
276	root	1.35	};
277
278	pippijn	1.24	cf::register_command 'output-count' => sub {
279			my ($ob, $arg) = @_;
280
281			return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
282			unless $arg > 0;
283
284	root	1.41	$arg = 4 if $arg < 4;
285
286	pippijn	1.24	$ob->contr->outputs_count ($arg);
287			$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
288			};
289
290			cf::register_command 'output-sync' => sub {
291			my ($ob, $arg) = @_;
292
293	root	1.38	return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
294			unless length $arg;
295	pippijn	1.24
296	root	1.41	$arg = 0.5 if $arg < 0.5;
297
298	root	1.38	$ob->contr->outputs_sync ($arg / $cf::TICK);
299			$ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
300	pippijn	1.24	};
301
302	pippijn	1.20	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
303			# some other level (which may also be 0), this does not get echoed,
304			# but it does get set.
305			cf::register_command wimpy => sub {
306			my ($ob, $arg) = @_;
307
308			my $wimpy = $ob->run_away;
309			return $ob->reply (undef, "Your current wimpy level is $wimpy.")
310			if $arg eq "";
311
312			return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
313			if $arg =~ /^\d+$/ and $arg <= 100;
314
315			$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
316			};
317
318			cf::register_command peaceful => sub {
319			my ($ob, $arg) = @_;
320
321			$ob->reply (undef, "You cannot change your peaceful setting with this command."
322			." Please speak to the priest in the temple of Gorokh"
323			." if you want to become hostile or in temple of Valriel"
324			." if you want to become peaceful again.");
325
326			#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
327			#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
328	root	1.58	};
329
330			sub rename_to($$$) {
331			my ($ob, $from, $to) = @_;
332
333			$to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
334			or return $ob->message ("rename: name must consist only of letters, digits, spaces and a few other things.");
335
336			127 >= length $to
337			or return $ob->message ("rename: new name must be <= 127 characters.");
338
339			my $item;
340
341			if (length $from) {
342			$item = $ob->find_best_object_match ($from)
343			or return $ob->message ("rename: could not find a matching item to rename.");
344			} else {
345			$item = $ob->find_marked_object
346			or return $ob->message ("rename: no from name and no marked item found to rename.");
347			}
348	pippijn	1.22
349	root	1.58	$item->custom_name (length $to ? $to : undef);
350
351			if (length $to) {
352			$item->custom_name ($to);
353			$ob->message ("Your " . $item->base_name . " will now be called $to.");
354			} else {
355			$item->custom_name (undef);
356			$ob->message ("You stop calling your " . $item->base_name . " with weird names.");
357			}
358
359			$ob->esrv_update_item (cf::UPD_NAME, $item);
360
361			1
362			}
363	pippijn	1.20
364	root	1.1	cf::register_command rename => sub {
365			my ($ob, $arg) = @_;
366
367			$ob->speed_left ($ob->speed_left - 0.25);
368
369			if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>])> \s$/x) {
370			# compatibility syntax
371			rename_to $ob, $1, $2;
372			} elsif ($arg =~ /
373			^\s*
374			(?:
375			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
376			\s+)?
377			to \s+
378			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
379			\s*$
380			/x) {
381			# does not unquote $1 or $3
382			rename_to $ob, $2\|\|$1, $4\|\|$3;
383			} else {
384			$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
385			}
386			};
387
388			cf::register_command uptime => sub {
389			my ($ob, $arg) = @_;
390
391			my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
392			my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
393	root	1.65	$ob->send_msg ("c/uptime" => "server started $startup, uptime ${runtime}\d", cf::NDI_REPLY \| cf::NDI_CLEAR);
394	root	1.1	};
395
396	root	1.8	my %IN_MEMORY = (
397	root	1.67	cf::MAP_ACTIVE => "I",
398	root	1.8	cf::MAP_SWAPPED => "S",
399			cf::MAP_LOADING => "L",
400			);
401
402	root	1.7	cf::register_command maps => sub {
403			my ($ob, $arg) = @_;
404
405			no re 'eval'; $arg = qr<$arg>;
406
407	root	1.68	my $format = " %2s %1s %3s %5s %.60s\n";
408	root	1.7
409	root	1.68	my $msg = "\n" . sprintf $format, "Pl", "I", "Svd", "Reset", "Name";
410	root	1.7
411			for (sort keys %cf::MAP) {
412			my $map = $cf::MAP{$_}
413			or next;
414
415			next unless $map->path =~ $arg;
416	root	1.17	next if $map->{deny_list};
417	root	1.7
418	root	1.10	my $svd = int $cf::RUNTIME - $map->{last_save};
419			$svd = "++" if $svd > 99;
420
421	root	1.68	$msg .= sprintf $format,
422			(scalar $map->players),
423			$IN_MEMORY{$map->in_memory} \|\| "?",
424			$svd,
425			(int $map->reset_at - $cf::RUNTIME),
426			$map->visible_name;
427	root	1.7	}
428	root	1.68
429			$ob->send_msg ("c/mapinfo" => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
430	root	1.7	};
431