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

   1
};

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

   1
};

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

   1
};

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

   1
};

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

   1
};

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

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

   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.22
Committed:	Fri Mar 2 10:44:56 2007 UTC (19 years, 7 months ago) by pippijn
Branch:	MAIN
Changes since 1.21:	+12 -0 lines
Log Message:	make commands return 1
#	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	pippijn	1.22
114			1
115	pippijn	1.21	};
116
117	pippijn	1.19	cf::register_command afk => sub {
118			my ($ob, $arg) = @_;
119
120			$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
121			$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
122	pippijn	1.22
123			1
124	pippijn	1.19	};
125
126	pippijn	1.21	cf::register_command sound => sub {
127			my ($ob, $arg) = @_;
128
129			$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
130			$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
131	pippijn	1.22
132			1
133	pippijn	1.21	};
134
135	pippijn	1.20	cf::register_command brace => sub {
136			my ($ob, $arg) = @_;
137
138			$ob->contr->braced ($ob->contr->braced ? 0 : 1);
139			$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
140	pippijn	1.22
141			1
142	pippijn	1.20	};
143
144			# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
145			# some other level (which may also be 0), this does not get echoed,
146			# but it does get set.
147			cf::register_command wimpy => sub {
148			my ($ob, $arg) = @_;
149
150			my $wimpy = $ob->run_away;
151			return $ob->reply (undef, "Your current wimpy level is $wimpy.")
152			if $arg eq "";
153
154			return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
155			if $arg =~ /^\d+$/ and $arg <= 100;
156
157			$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
158	pippijn	1.22
159			1
160	pippijn	1.20	};
161
162			cf::register_command peaceful => sub {
163			my ($ob, $arg) = @_;
164
165			$ob->reply (undef, "You cannot change your peaceful setting with this command."
166			." Please speak to the priest in the temple of Gorokh"
167			." if you want to become hostile or in temple of Valriel"
168			." if you want to become peaceful again.");
169
170			#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
171			#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
172	pippijn	1.22
173			1
174	pippijn	1.20	};
175
176
177	root	1.1	cf::register_command rename => sub {
178			my ($ob, $arg) = @_;
179
180			$ob->speed_left ($ob->speed_left - 0.25);
181
182			if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>])> \s$/x) {
183			# compatibility syntax
184			rename_to $ob, $1, $2;
185			} elsif ($arg =~ /
186			^\s*
187			(?:
188			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
189			\s+)?
190			to \s+
191			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
192			\s*$
193			/x) {
194			# does not unquote $1 or $3
195			rename_to $ob, $2\|\|$1, $4\|\|$3;
196			} else {
197			$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
198			}
199
200			1
201			};
202
203			cf::register_command uptime => sub {
204			my ($ob, $arg) = @_;
205
206			my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
207			my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
208			$ob->reply (undef, "server started $startup, uptime ${runtime}\d");
209
210			1
211			};
212
213	root	1.8	my %IN_MEMORY = (
214			cf::MAP_IN_MEMORY => "I",
215			cf::MAP_SWAPPED => "S",
216			cf::MAP_LOADING => "L",
217			);
218
219	root	1.7	cf::register_command maps => sub {
220			my ($ob, $arg) = @_;
221
222			no re 'eval'; $arg = qr<$arg>;
223
224	root	1.13	my $format = "%2s %1s %3s %5s %.60s\n";
225	root	1.7
226	root	1.15	$ob->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK \| cf::NDI_UNIQUE);
227	root	1.7
228			for (sort keys %cf::MAP) {
229			my $map = $cf::MAP{$_}
230			or next;
231
232			next unless $map->path =~ $arg;
233	root	1.17	next if $map->{deny_list};
234	root	1.7
235	root	1.10	my $svd = int $cf::RUNTIME - $map->{last_save};
236			$svd = "++" if $svd > 99;
237
238	root	1.14	$ob->reply (undef,
239			(sprintf $format,
240			(scalar $map->players),
241			$IN_MEMORY{$map->in_memory} \|\| "?",
242			$svd,
243			(int $map->reset_at - $cf::RUNTIME),
244	root	1.17	$map->visible_name),
245	root	1.14	cf::NDI_BLACK \| cf::NDI_UNIQUE);
246	root	1.7	}
247
248			1
249			};
250