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->contr->ns->send_msg (log => (join "\n\n", who_listing $ob->may ("extended_who"), $arg), cf::NDI_DK_ORANGE);
};

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_UNIQUE);
      } elsif (cf::player::find_active $login) {
         $pl->message ("$login is right here on this server!", cf::NDI_UNIQUE);
      } 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_UNIQUE);
      } else {
         $pl->message ("No player named $login is known to me.", cf::NDI_UNIQUE);
      }
   } else {
      $pl->message ("Usage: seen <player>", cf::NDI_UNIQUE);
   }
};

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->reply (undef, $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;
   $ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $observe->region->longname));
   $ob->reply (undef, (sprintf "players: %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->reply (undef, $map->msg);
};

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

   my $reg = $ob->contr->observe->region;
   $ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg));
};

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) in $_\n\n", sort keys %count;

   $ob->contr->ns->send_msg (log => $msg, cf::NDI_REPLY);
};

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

   my $url = $cf::CFG->{hiscore_url};
   $ob->contr->ns->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->reply (undef, "server started $startup, uptime ${runtime}\d");
};

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->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK | cf::NDI_UNIQUE);

   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->reply (undef,
                  (sprintf $format,
                   (scalar $map->players), 
                   $IN_MEMORY{$map->in_memory} || "?",
                   $svd,
                   (int $map->reset_at - $cf::RUNTIME),
                   $map->visible_name),
                  cf::NDI_BLACK | cf::NDI_UNIQUE);
   }
};

Revision:	1.59
Committed:	Fri Aug 10 05:27:38 2007 UTC (16 years, 9 months ago) by root
Branch:	MAIN
Changes since 1.58:	+1 -1 lines
Log Message:	minor stuff
#	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.59	$ob->contr->ns->send_msg (log => (join "\n\n", who_listing $ob->may ("extended_who"), $arg), cf::NDI_DK_ORANGE);
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			$pl->message ("Very funny, $login. Ha. Ha.", cf::NDI_UNIQUE);
61			} elsif (cf::player::find_active $login) {
62			$pl->message ("$login is right here on this server!", cf::NDI_UNIQUE);
63			} 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			. " which was " . (int +(time - $time) / 3600) . " hours ago.", cf::NDI_UNIQUE);
70			} else {
71			$pl->message ("No player named $login is known to me.", cf::NDI_UNIQUE);
72			}
73			} else {
74			$pl->message ("Usage: seen <player>", cf::NDI_UNIQUE);
75			}
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.44	$ob->reply (undef, $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.56	$ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $observe->region->longname));
151	pippijn	1.26	$ob->reply (undef, (sprintf "players: %d difficulty: %d size: %d start: %dx%d timeout: %d",
152	root	1.53	(scalar $map->players), $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout))
153	pippijn	1.26	if $ob->flag (cf::FLAG_WIZ);
154			$ob->reply (undef, $map->msg);
155			};
156
157	pippijn	1.25	cf::register_command whereami => sub {
158			my ($ob) = @_;
159
160	root	1.50	my $reg = $ob->contr->observe->region;
161	pippijn	1.25	$ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg));
162	root	1.58	};
163
164			cf::register_command whereabouts => sub {
165			my ($ob, $arg) = @_;
166
167			my %count;
168
169			for my $pl (cf::player::list) {
170			++$count{$pl->ob->region->longname};
171			}
172
173			my $msg = "In the world currently there are:\n\n"
174			. join "", map "$count{$_} player(s) in $_\n\n", sort keys %count;
175
176			$ob->contr->ns->send_msg (log => $msg, cf::NDI_REPLY);
177			};
178
179			cf::register_command hiscore => sub {
180			my ($ob, $arg) = @_;
181	pippijn	1.25
182	root	1.58	my $url = $cf::CFG->{hiscore_url};
183			$ob->contr->ns->send_msg (log => "See $url", cf::NDI_REPLY);
184	pippijn	1.25	};
185
186	root	1.31	sub _set_mode($$$@) {
187			my ($name, $ob, $arg, $slot, @choices) = @_;
188	pippijn	1.23
189	root	1.31	my $oldmode = $ob->contr->$slot;
190	pippijn	1.23
191	root	1.31	return $ob->reply (undef, "$name is set to $choices[$oldmode]")
192	pippijn	1.23	unless $arg;
193
194	root	1.31	my ($idx) = grep $choices[$_] eq $arg, 0 .. $#choices
195			or return $ob->reply (undef, "$name: Unknown options '$arg', valid options are @choices"), 1;
196	pippijn	1.23
197	root	1.31	$ob->contr->$slot ($idx);
198			$ob->reply (undef, "$name" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $choices[$ob->contr->$slot]);
199			}
200
201			cf::register_command applymode => sub {
202			my ($ob, $arg) = @_;
203
204			_set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
205	pippijn	1.23	};
206
207			cf::register_command petmode => sub {
208			my ($ob, $arg) = @_;
209
210	root	1.31	_set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
211	pippijn	1.23	};
212
213	pippijn	1.21	cf::register_command usekeys => sub {
214			my ($ob, $arg) = @_;
215
216	root	1.31	_set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
217	pippijn	1.21	};
218
219	root	1.51	cf::register_command hintmode => sub {
220			my ($ob, $arg) = @_;
221
222			_set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);
223			};
224
225	pippijn	1.19	cf::register_command afk => sub {
226			my ($ob, $arg) = @_;
227
228			$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
229			$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
230			};
231
232	pippijn	1.21	cf::register_command sound => sub {
233			my ($ob, $arg) = @_;
234
235			$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
236			$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
237			};
238
239	pippijn	1.20	cf::register_command brace => sub {
240			my ($ob, $arg) = @_;
241
242			$ob->contr->braced ($ob->contr->braced ? 0 : 1);
243			$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
244			};
245
246	root	1.35	cf::register_command 'output-rate' => sub {
247			my ($ob, $arg) = @_;
248
249			return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
250			unless $arg > 0;
251
252	root	1.54	# minimum is 5k/s
253	root	1.57	# maximum is 100k/s, this should be configurable
254			$ob->contr->ns->max_rate ((List::Util::max 5000, List::Util::min 100000, $arg) * $cf::TICK);
255	root	1.36	$ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
256	root	1.35	};
257
258	pippijn	1.24	cf::register_command 'output-count' => sub {
259			my ($ob, $arg) = @_;
260
261			return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
262			unless $arg > 0;
263
264	root	1.41	$arg = 4 if $arg < 4;
265
266	pippijn	1.24	$ob->contr->outputs_count ($arg);
267			$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
268			};
269
270			cf::register_command 'output-sync' => sub {
271			my ($ob, $arg) = @_;
272
273	root	1.38	return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
274			unless length $arg;
275	pippijn	1.24
276	root	1.41	$arg = 0.5 if $arg < 0.5;
277
278	root	1.38	$ob->contr->outputs_sync ($arg / $cf::TICK);
279			$ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
280	pippijn	1.24	};
281
282	pippijn	1.20	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
283			# some other level (which may also be 0), this does not get echoed,
284			# but it does get set.
285			cf::register_command wimpy => sub {
286			my ($ob, $arg) = @_;
287
288			my $wimpy = $ob->run_away;
289			return $ob->reply (undef, "Your current wimpy level is $wimpy.")
290			if $arg eq "";
291
292			return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
293			if $arg =~ /^\d+$/ and $arg <= 100;
294
295			$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
296			};
297
298			cf::register_command peaceful => sub {
299			my ($ob, $arg) = @_;
300
301			$ob->reply (undef, "You cannot change your peaceful setting with this command."
302			." Please speak to the priest in the temple of Gorokh"
303			." if you want to become hostile or in temple of Valriel"
304			." if you want to become peaceful again.");
305
306			#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
307			#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
308	root	1.58	};
309
310			sub rename_to($$$) {
311			my ($ob, $from, $to) = @_;
312
313			$to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
314			or return $ob->message ("rename: name must consist only of letters, digits, spaces and a few other things.");
315
316			127 >= length $to
317			or return $ob->message ("rename: new name must be <= 127 characters.");
318
319			my $item;
320
321			if (length $from) {
322			$item = $ob->find_best_object_match ($from)
323			or return $ob->message ("rename: could not find a matching item to rename.");
324			} else {
325			$item = $ob->find_marked_object
326			or return $ob->message ("rename: no from name and no marked item found to rename.");
327			}
328	pippijn	1.22
329	root	1.58	$item->custom_name (length $to ? $to : undef);
330
331			if (length $to) {
332			$item->custom_name ($to);
333			$ob->message ("Your " . $item->base_name . " will now be called $to.");
334			} else {
335			$item->custom_name (undef);
336			$ob->message ("You stop calling your " . $item->base_name . " with weird names.");
337			}
338
339			$ob->esrv_update_item (cf::UPD_NAME, $item);
340
341			1
342			}
343	pippijn	1.20
344	root	1.1	cf::register_command rename => sub {
345			my ($ob, $arg) = @_;
346
347			$ob->speed_left ($ob->speed_left - 0.25);
348
349			if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>])> \s$/x) {
350			# compatibility syntax
351			rename_to $ob, $1, $2;
352			} elsif ($arg =~ /
353			^\s*
354			(?:
355			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
356			\s+)?
357			to \s+
358			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
359			\s*$
360			/x) {
361			# does not unquote $1 or $3
362			rename_to $ob, $2\|\|$1, $4\|\|$3;
363			} else {
364			$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
365			}
366			};
367
368			cf::register_command uptime => sub {
369			my ($ob, $arg) = @_;
370
371			my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
372			my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
373			$ob->reply (undef, "server started $startup, uptime ${runtime}\d");
374			};
375
376	root	1.8	my %IN_MEMORY = (
377			cf::MAP_IN_MEMORY => "I",
378			cf::MAP_SWAPPED => "S",
379			cf::MAP_LOADING => "L",
380			);
381
382	root	1.7	cf::register_command maps => sub {
383			my ($ob, $arg) = @_;
384
385			no re 'eval'; $arg = qr<$arg>;
386
387	root	1.13	my $format = "%2s %1s %3s %5s %.60s\n";
388	root	1.7
389	root	1.15	$ob->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK \| cf::NDI_UNIQUE);
390	root	1.7
391			for (sort keys %cf::MAP) {
392			my $map = $cf::MAP{$_}
393			or next;
394
395			next unless $map->path =~ $arg;
396	root	1.17	next if $map->{deny_list};
397	root	1.7
398	root	1.10	my $svd = int $cf::RUNTIME - $map->{last_save};
399			$svd = "++" if $svd > 99;
400
401	root	1.14	$ob->reply (undef,
402			(sprintf $format,
403			(scalar $map->players),
404			$IN_MEMORY{$map->in_memory} \|\| "?",
405			$svd,
406			(int $map->reset_at - $cf::RUNTIME),
407	root	1.17	$map->visible_name),
408	root	1.14	cf::NDI_BLACK \| cf::NDI_UNIQUE);
409	root	1.7	}
410			};
411