server/ext/commands.ext

#! perl

use POSIX ();

# miscellaneous commands

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
}

sub ext::schmorp_irc::users; # HACK: TODO: replace by signal

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

   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)",
      (
         map {
            my ($pl, $ob, $ns) = ($_, $_->ob, $_->ns);
    
            "* " . $ob->name . "/" . $ob->level . " " . (length $pl->own_title ? $pl->own_title : "the " . $pl->title)
            . ($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->rtt * 1e-6)
            . ($privileged ? " " . $pl->ns->host : "")
         } sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl
      ),
      eval { "* IRC: " . join ", ", ext::schmorp_irc::users },
   )
}

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

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

   $ob->reply (undef, (join "\n", who_listing $ob->may ("extended_who")), cf::NDI_UNIQUE | cf::NDI_DK_ORANGE);

   1
};

cf::register_command usekeys => sub {
   my ($ob, $arg) = @_;
   my @types = ("inventory", "keyrings", "containers");
   my $mapping = {
      inventory  => 1,
      keyrings   => 2,
      containers => 3,
   };

   my $oldtype = $ob->contr->usekeys;
   my $oldtype_name = $types[$oldtype];

   return $ob->reply (undef, "usekeys is set to $oldtype_name")
      unless $arg;

   return $ob->reply (undef, "usekeys: Unknown options '$arg', valid options are inventory, keyrings, containers")
      unless $mapping->{$arg};

   $ob->contr->usekeys ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
                                               # but $arg would be 0 if a user enters an incorrect value
   $ob->reply (undef, "usekeys" . ($oldtype == $ob->contr->usekeys ? "" : " now") . " set to " . $types[$ob->contr->usekeys]);
};

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.");
};

# 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.");
};


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"');
   }

   1
};

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");

   1
};

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);
   }

   1
};

Revision:	1.21
Committed:	Fri Mar 2 10:43:01 2007 UTC (17 years, 2 months ago) by pippijn
Branch:	MAIN
Changes since 1.20:	+30 -0 lines
Log Message:	sound, usekeys in perl
#	User	Rev	Content
1	root	1.1	#! perl
2
3			use POSIX ();
4
5			# miscellaneous commands
6
7			sub rename_to($$$) {
8			my ($ob, $from, $to) = @_;
9
10	root	1.12	$to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
11	root	1.1	or return $ob->message ("rename: name must consist only of letters, digits, spaces and a few other things.");
12
13			127 >= length $to
14			or return $ob->message ("rename: new name must be <= 127 characters.");
15
16			my $item;
17
18			if (length $from) {
19			$item = $ob->find_best_object_match ($from)
20			or return $ob->message ("rename: could not find a matching item to rename.");
21			} else {
22			$item = $ob->find_marked_object ()
23			or return $ob->message ("rename: no from name and no marked item found to rename.");
24			}
25
26			$item->custom_name (length $to ? $to : undef);
27
28			if (length $to) {
29			$item->custom_name ($to);
30			$ob->message ("Your " . $item->base_name . " will now be called $to.");
31			} else {
32			$item->custom_name (undef);
33			$ob->message ("You stop calling your " . $item->base_name . " with weird names.");
34			}
35
36			$ob->esrv_update_item (cf::UPD_NAME, $item);
37
38			1
39			}
40
41			sub ext::schmorp_irc::users; # HACK: TODO: replace by signal
42
43			sub who_listing(;$) {
44			my ($privileged) = @_;
45
46			my ($numwiz, $numafk) = (0, 0);
47			my @pl;
48
49			foreach my $pl (cf::player::list) {
50	root	1.5	my $ns = $pl->ns or next;
51	root	1.1	my $ob = $pl->ob;
52
53			next unless $ob->map
54			&& ($privileged \|\| !$pl->hidden);
55
56			$numwiz++ if $ob->flag (cf::FLAG_WIZ);
57	root	1.5	$numafk++ if $ns->afk;
58	root	1.1
59			push @pl, $pl;
60			}
61
62			(
63			"Total Players in The World. (" . (scalar @pl) . ") -- WIZ($numwiz) AFK($numafk) BOT(0)",
64			(
65			map {
66	root	1.5	my ($pl, $ob, $ns) = ($_, $_->ob, $_->ns);
67	root	1.1
68			"* " . $ob->name . "/" . $ob->level . " " . (length $pl->own_title ? $pl->own_title : "the " . $pl->title)
69			. ($pl->peaceful ? " [peaceful]" : " [HOSTILE]")
70	root	1.5	. ($ns->afk ? " [AFK]" : "")
71	root	1.1	. ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "")
72	root	1.4	. " [" . $pl->ns->version . "]"
73	root	1.18	. " [" . ($pl->peaceful \|\| $privileged ? $ob->map->visible_name : $ob->region->name) . "]"
74	root	1.4	. (sprintf " [rtt %.3fs]", $pl->ns->rtt * 1e-6)
75			. ($privileged ? " " . $pl->ns->host : "")
76	root	1.1	} sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl
77			),
78			eval { "* IRC: " . join ", ", ext::schmorp_irc::users },
79			)
80			}
81
82			cf::register_command who => sub {
83			my ($ob, $arg) = @_;
84
85			$ob->speed_left ($ob->speed_left - 0.25);
86
87			$ob->reply (undef, (join "\n", who_listing $ob->may ("extended_who")), cf::NDI_UNIQUE \| cf::NDI_DK_ORANGE);
88
89			1
90			};
91
92	pippijn	1.21	cf::register_command usekeys => sub {
93			my ($ob, $arg) = @_;
94			my @types = ("inventory", "keyrings", "containers");
95			my $mapping = {
96			inventory => 1,
97			keyrings => 2,
98			containers => 3,
99			};
100
101			my $oldtype = $ob->contr->usekeys;
102			my $oldtype_name = $types[$oldtype];
103
104			return $ob->reply (undef, "usekeys is set to $oldtype_name")
105			unless $arg;
106
107			return $ob->reply (undef, "usekeys: Unknown options '$arg', valid options are inventory, keyrings, containers")
108			unless $mapping->{$arg};
109
110			$ob->contr->usekeys ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
111			# but $arg would be 0 if a user enters an incorrect value
112			$ob->reply (undef, "usekeys" . ($oldtype == $ob->contr->usekeys ? "" : " now") . " set to " . $types[$ob->contr->usekeys]);
113			};
114
115	pippijn	1.19	cf::register_command afk => sub {
116			my ($ob, $arg) = @_;
117
118			$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
119			$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
120			};
121
122	pippijn	1.21	cf::register_command sound => sub {
123			my ($ob, $arg) = @_;
124
125			$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
126			$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
127			};
128
129	pippijn	1.20	cf::register_command brace => sub {
130			my ($ob, $arg) = @_;
131
132			$ob->contr->braced ($ob->contr->braced ? 0 : 1);
133			$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
134			};
135
136			# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
137			# some other level (which may also be 0), this does not get echoed,
138			# but it does get set.
139			cf::register_command wimpy => sub {
140			my ($ob, $arg) = @_;
141
142			my $wimpy = $ob->run_away;
143			return $ob->reply (undef, "Your current wimpy level is $wimpy.")
144			if $arg eq "";
145
146			return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
147			if $arg =~ /^\d+$/ and $arg <= 100;
148
149			$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
150			};
151
152			cf::register_command peaceful => sub {
153			my ($ob, $arg) = @_;
154
155			$ob->reply (undef, "You cannot change your peaceful setting with this command."
156			." Please speak to the priest in the temple of Gorokh"
157			." if you want to become hostile or in temple of Valriel"
158			." if you want to become peaceful again.");
159
160			#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
161			#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
162			};
163
164
165	root	1.1	cf::register_command rename => sub {
166			my ($ob, $arg) = @_;
167
168			$ob->speed_left ($ob->speed_left - 0.25);
169
170			if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>])> \s$/x) {
171			# compatibility syntax
172			rename_to $ob, $1, $2;
173			} elsif ($arg =~ /
174			^\s*
175			(?:
176			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
177			\s+)?
178			to \s+
179			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
180			\s*$
181			/x) {
182			# does not unquote $1 or $3
183			rename_to $ob, $2\|\|$1, $4\|\|$3;
184			} else {
185			$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
186			}
187
188			1
189			};
190
191			cf::register_command uptime => sub {
192			my ($ob, $arg) = @_;
193
194			my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
195			my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
196			$ob->reply (undef, "server started $startup, uptime ${runtime}\d");
197
198			1
199			};
200
201	root	1.8	my %IN_MEMORY = (
202			cf::MAP_IN_MEMORY => "I",
203			cf::MAP_SWAPPED => "S",
204			cf::MAP_LOADING => "L",
205			);
206
207	root	1.7	cf::register_command maps => sub {
208			my ($ob, $arg) = @_;
209
210			no re 'eval'; $arg = qr<$arg>;
211
212	root	1.13	my $format = "%2s %1s %3s %5s %.60s\n";
213	root	1.7
214	root	1.15	$ob->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK \| cf::NDI_UNIQUE);
215	root	1.7
216			for (sort keys %cf::MAP) {
217			my $map = $cf::MAP{$_}
218			or next;
219
220			next unless $map->path =~ $arg;
221	root	1.17	next if $map->{deny_list};
222	root	1.7
223	root	1.10	my $svd = int $cf::RUNTIME - $map->{last_save};
224			$svd = "++" if $svd > 99;
225
226	root	1.14	$ob->reply (undef,
227			(sprintf $format,
228			(scalar $map->players),
229			$IN_MEMORY{$map->in_memory} \|\| "?",
230			$svd,
231			(int $map->reset_at - $cf::RUNTIME),
232	root	1.17	$map->visible_name),
233	root	1.14	cf::NDI_BLACK \| cf::NDI_UNIQUE);
234	root	1.7	}
235
236			1
237			};
238