ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
(Generate patch)

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.458 by root, Sat Dec 13 20:34:37 2008 UTC vs.
Revision 1.486 by root, Thu Oct 15 21:56:50 2009 UTC

1# 1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG. 2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3# 3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5# 5#
6# Deliantra is free software: you can redistribute it and/or modify 6# Deliantra is free software: you can redistribute it and/or modify it under
7# it under the terms of the GNU General Public License as published by 7# the terms of the Affero GNU General Public License as published by the
8# the Free Software Foundation, either version 3 of the License, or 8# Free Software Foundation, either version 3 of the License, or (at your
9# (at your option) any later version. 9# option) any later version.
10# 10#
11# This program is distributed in the hope that it will be useful, 11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of 12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details. 14# GNU General Public License for more details.
15# 15#
16# You should have received a copy of the GNU General Public License 16# You should have received a copy of the Affero GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>. 17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
18# 19#
19# The authors can be reached via e-mail to <support@deliantra.net> 20# The authors can be reached via e-mail to <support@deliantra.net>
20# 21#
21 22
22package cf; 23package cf;
23 24
24use 5.10.0; 25use 5.10.0;
25use utf8; 26use utf8;
26use strict "vars", "subs"; 27use strict qw(vars subs);
27 28
28use Symbol; 29use Symbol;
29use List::Util; 30use List::Util;
30use Socket; 31use Socket;
31use EV; 32use EV;
… …
41use Coro::EV; 42use Coro::EV;
42use Coro::AnyEvent; 43use Coro::AnyEvent;
43use Coro::Timer; 44use Coro::Timer;
44use Coro::Signal; 45use Coro::Signal;
45use Coro::Semaphore; 46use Coro::Semaphore;
47use Coro::SemaphoreSet;
46use Coro::AnyEvent; 48use Coro::AnyEvent;
47use Coro::AIO; 49use Coro::AIO;
48use Coro::BDB 1.6; 50use Coro::BDB 1.6;
49use Coro::Storable; 51use Coro::Storable;
50use Coro::Util (); 52use Coro::Util ();
… …
52use JSON::XS 2.01 (); 54use JSON::XS 2.01 ();
53use BDB (); 55use BDB ();
54use Data::Dumper; 56use Data::Dumper;
55use Digest::MD5; 57use Digest::MD5;
56use Fcntl; 58use Fcntl;
57use YAML (); 59use YAML::XS ();
58use IO::AIO (); 60use IO::AIO ();
59use Time::HiRes; 61use Time::HiRes;
60use Compress::LZF; 62use Compress::LZF;
61use Digest::MD5 (); 63use Digest::MD5 ();
62 64
… …
70$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 72$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
71 73
72# make sure c-lzf reinitialises itself 74# make sure c-lzf reinitialises itself
73Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve"; 75Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
74Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 76Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
77
78# strictly for debugging
79$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
75 80
76sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
77 82
78our %COMMAND = (); 83our %COMMAND = ();
79our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
… …
84our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
85our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
86 91
87our $RELOAD; # number of reloads so far, non-zero while in reload 92our $RELOAD; # number of reloads so far, non-zero while in reload
88our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS
95our %REFLECT; # set by us
89 96
90our $CONFDIR = confdir; 97our $CONFDIR = confdir;
91our $DATADIR = datadir; 98our $DATADIR = datadir;
92our $LIBDIR = "$DATADIR/ext"; 99our $LIBDIR = "$DATADIR/ext";
93our $PODDIR = "$DATADIR/pod"; 100our $PODDIR = "$DATADIR/pod";
… …
104our %RESOURCE; 111our %RESOURCE;
105 112
106our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 113our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
107our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 114our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
108our $NEXT_TICK; 115our $NEXT_TICK;
109our $USE_FSYNC = 1; # use fsync to write maps - default off 116our $USE_FSYNC = 1; # use fsync to write maps - default on
110 117
111our $BDB_DEADLOCK_WATCHER; 118our $BDB_DEADLOCK_WATCHER;
112our $BDB_CHECKPOINT_WATCHER; 119our $BDB_CHECKPOINT_WATCHER;
113our $BDB_TRICKLE_WATCHER; 120our $BDB_TRICKLE_WATCHER;
114our $DB_ENV; 121our $DB_ENV;
115 122
123our @EXTRA_MODULES = qw(pod match mapscript);
124
116our %CFG; 125our %CFG;
117 126
118our $UPTIME; $UPTIME ||= time; 127our $UPTIME; $UPTIME ||= time;
119our $RUNTIME; 128our $RUNTIME;
120our $NOW; 129our $NOW;
… …
131our $JITTER; # average jitter 140our $JITTER; # average jitter
132our $TICK_START; # for load detecting purposes 141our $TICK_START; # for load detecting purposes
133 142
134our @POST_INIT; 143our @POST_INIT;
135 144
136our $REATTACH_ON_RELOAD; # ste to true to force object reattach on reload (slow) 145our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
146our $REALLY_UNLOOP; # never set to true, please :)
137 147
138binmode STDOUT; 148binmode STDOUT;
139binmode STDERR; 149binmode STDERR;
140 150
141# read virtual server time, if available 151# read virtual server time, if available
… …
143 open my $fh, "<", $RUNTIMEFILE 153 open my $fh, "<", $RUNTIMEFILE
144 or die "unable to read $RUNTIMEFILE file: $!"; 154 or die "unable to read $RUNTIMEFILE file: $!";
145 $RUNTIME = <$fh> + 0.; 155 $RUNTIME = <$fh> + 0.;
146} 156}
147 157
158eval "sub TICK() { $TICK } 1" or die;
159
148mkdir $_ 160mkdir $_
149 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 161 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
150 162
151our $EMERGENCY_POSITION; 163our $EMERGENCY_POSITION;
152 164
153sub cf::map::normalise; 165sub cf::map::normalise;
166
167#############################################################################
168
169%REFLECT = ();
170for (@REFLECT) {
171 my $reflect = JSON::XS::decode_json $_;
172 $REFLECT{$reflect->{class}} = $reflect;
173}
174
175# this is decidedly evil
176$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
154 177
155############################################################################# 178#############################################################################
156 179
157=head2 GLOBAL VARIABLES 180=head2 GLOBAL VARIABLES
158 181
… …
209 232
210This array contains the results of the last C<invoke ()> call. When 233This array contains the results of the last C<invoke ()> call. When
211C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 234C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
212that call. 235that call.
213 236
237=item %cf::REFLECT
238
239Contains, for each (C++) class name, a hash reference with information
240about object members (methods, scalars, arrays and flags) and other
241metadata, which is useful for introspection.
242
214=back 243=back
215 244
216=cut 245=cut
217 246
218BEGIN { 247$Coro::State::WARNHOOK = sub {
219 *CORE::GLOBAL::warn = sub {
220 my $msg = join "", @_; 248 my $msg = join "", @_;
221 249
222 $msg .= "\n" 250 $msg .= "\n"
223 unless $msg =~ /\n$/; 251 unless $msg =~ /\n$/;
224 252
225 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 253 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
226 254
227 LOG llevError, $msg; 255 LOG llevError, $msg;
228 }; 256};
229}
230 257
231$Coro::State::DIEHOOK = sub { 258$Coro::State::DIEHOOK = sub {
232 return unless $^S eq 0; # "eq", not "==" 259 return unless $^S eq 0; # "eq", not "=="
260
261 warn Carp::longmess $_[0];
233 262
234 if ($Coro::current == $Coro::main) {#d# 263 if ($Coro::current == $Coro::main) {#d#
235 warn "DIEHOOK called in main context, Coro bug?\n";#d# 264 warn "DIEHOOK called in main context, Coro bug?\n";#d#
236 return;#d# 265 return;#d#
237 }#d# 266 }#d#
238 267
239 # kill coroutine otherwise 268 # kill coroutine otherwise
240 warn Carp::longmess $_[0];
241 Coro::terminate 269 Coro::terminate
242}; 270};
243
244$SIG{__DIE__} = sub { }; #d#?
245 271
246@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 272@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
247@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 273@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
248@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 274@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
249@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 275@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
347 373
348Return true if the lock is currently active, i.e. somebody has locked it. 374Return true if the lock is currently active, i.e. somebody has locked it.
349 375
350=cut 376=cut
351 377
352our %LOCK; 378our $LOCKS = new Coro::SemaphoreSet;
353our %LOCKER;#d#
354 379
355sub lock_wait($) { 380sub lock_wait($) {
356 my ($key) = @_; 381 $LOCKS->wait ($_[0]);
357
358 if ($LOCKER{$key} == $Coro::current) {#d#
359 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
360 return;#d#
361 }#d#
362
363 # wait for lock, if any
364 while ($LOCK{$key}) {
365 #local $Coro::current->{desc} = "$Coro::current->{desc} <waiting for lock $key>";
366 push @{ $LOCK{$key} }, $Coro::current;
367 Coro::schedule;
368 }
369} 382}
370 383
371sub lock_acquire($) { 384sub lock_acquire($) {
372 my ($key) = @_; 385 $LOCKS->guard ($_[0])
373
374 # wait, to be sure we are not locked
375 lock_wait $key;
376
377 $LOCK{$key} = [];
378 $LOCKER{$key} = $Coro::current;#d#
379
380 Guard::guard {
381 delete $LOCKER{$key};#d#
382 # wake up all waiters, to be on the safe side
383 $_->ready for @{ delete $LOCK{$key} };
384 }
385} 386}
386 387
387sub lock_active($) { 388sub lock_active($) {
388 my ($key) = @_; 389 $LOCKS->count ($_[0]) < 1
389
390 ! ! $LOCK{$key}
391} 390}
392 391
393sub freeze_mainloop { 392sub freeze_mainloop {
394 tick_inhibit_inc; 393 tick_inhibit_inc;
395 394
… …
1173 $decname, length $$rdata, scalar @$objs; 1172 $decname, length $$rdata, scalar @$objs;
1174 1173
1175 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1174 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1176 aio_chmod $fh, SAVE_MODE; 1175 aio_chmod $fh, SAVE_MODE;
1177 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1176 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1178 aio_fsync $fh if $cf::USE_FSYNC; 1177 if ($cf::USE_FSYNC) {
1178 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1179 aio_fsync $fh;
1180 }
1179 aio_close $fh; 1181 aio_close $fh;
1180 1182
1181 if (@$objs) { 1183 if (@$objs) {
1182 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1184 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1183 aio_chmod $fh, SAVE_MODE; 1185 aio_chmod $fh, SAVE_MODE;
1184 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1186 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1185 aio_write $fh, 0, (length $data), $data, 0; 1187 aio_write $fh, 0, (length $data), $data, 0;
1186 aio_fsync $fh if $cf::USE_FSYNC; 1188 if ($cf::USE_FSYNC) {
1189 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1190 aio_fsync $fh;
1191 }
1187 aio_close $fh; 1192 aio_close $fh;
1188 aio_rename "$filename.pst~", "$filename.pst"; 1193 aio_rename "$filename.pst~", "$filename.pst";
1189 } 1194 }
1190 } else { 1195 } else {
1191 aio_unlink "$filename.pst"; 1196 aio_unlink "$filename.pst";
… …
1194 aio_rename "$filename~", $filename; 1199 aio_rename "$filename~", $filename;
1195 1200
1196 $filename =~ s%/[^/]+$%%; 1201 $filename =~ s%/[^/]+$%%;
1197 aio_pathsync $filename if $cf::USE_FSYNC; 1202 aio_pathsync $filename if $cf::USE_FSYNC;
1198 } else { 1203 } else {
1199 warn "FATAL: $filename~: $!\n"; 1204 warn "unable to save objects: $filename~: $!\n";
1200 } 1205 }
1201 } else { 1206 } else {
1202 aio_unlink $filename; 1207 aio_unlink $filename;
1203 aio_unlink "$filename.pst"; 1208 aio_unlink "$filename.pst";
1204 } 1209 }
… …
1342 1347
1343# "readahead" all extensions 1348# "readahead" all extensions
1344sub cache_extensions { 1349sub cache_extensions {
1345 my $grp = IO::AIO::aio_group; 1350 my $grp = IO::AIO::aio_group;
1346 1351
1347 add $grp IO::AIO::aio_readdir $LIBDIR, sub { 1352 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1348 for (grep /\.ext$/, @{$_[0]}) { 1353 for (grep /\.ext$/, @{$_[0]}) {
1349 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data; 1354 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1350 } 1355 }
1351 }; 1356 };
1352 1357
… …
1888 1893
1889 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go; 1894 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1890 "$UNIQUEDIR/$path" 1895 "$UNIQUEDIR/$path"
1891} 1896}
1892 1897
1893# and all this just because we cannot iterate over
1894# all maps in C++...
1895sub change_all_map_light {
1896 my ($change) = @_;
1897
1898 $_->change_map_light ($change)
1899 for grep $_->outdoor, values %cf::MAP;
1900}
1901
1902sub decay_objects { 1898sub decay_objects {
1903 my ($self) = @_; 1899 my ($self) = @_;
1904 1900
1905 return if $self->{deny_reset}; 1901 return if $self->{deny_reset};
1906 1902
… …
1988sub find { 1984sub find {
1989 my ($path, $origin) = @_; 1985 my ($path, $origin) = @_;
1990 1986
1991 $path = normalise $path, $origin && $origin->path; 1987 $path = normalise $path, $origin && $origin->path;
1992 1988
1993 cf::lock_wait "map_data:$path";#d#remove 1989 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1994 cf::lock_wait "map_find:$path"; 1990 my $guard2 = cf::lock_acquire "map_find:$path";
1995 1991
1996 $cf::MAP{$path} || do { 1992 $cf::MAP{$path} || do {
1997 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1998 my $guard2 = cf::lock_acquire "map_find:$path";
1999
2000 my $map = new_from_path cf::map $path 1993 my $map = new_from_path cf::map $path
2001 or return; 1994 or return;
2002 1995
2003 $map->{last_save} = $cf::RUNTIME; 1996 $map->{last_save} = $cf::RUNTIME;
2004 1997
… …
2072 unless ($self->{deny_activate}) { 2065 unless ($self->{deny_activate}) {
2073 $self->decay_objects; 2066 $self->decay_objects;
2074 $self->fix_auto_apply; 2067 $self->fix_auto_apply;
2075 $self->update_buttons; 2068 $self->update_buttons;
2076 cf::cede_to_tick; 2069 cf::cede_to_tick;
2077 $self->set_darkness_map;
2078 cf::cede_to_tick;
2079 $self->activate; 2070 $self->activate;
2080 } 2071 }
2081 2072
2082 $self->{last_save} = $cf::RUNTIME; 2073 $self->{last_save} = $cf::RUNTIME;
2083 $self->last_access ($cf::RUNTIME); 2074 $self->last_access ($cf::RUNTIME);
… …
2249 2240
2250 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2241 my $lock = cf::lock_acquire "map_data:$self->{path}";
2251 2242
2252 return if $self->players; 2243 return if $self->players;
2253 2244
2254 warn "resetting map ", $self->path; 2245 warn "resetting map ", $self->path, "\n";
2255 2246
2256 $self->in_memory (cf::MAP_SWAPPED); 2247 $self->in_memory (cf::MAP_SWAPPED);
2257 2248
2258 # need to save uniques path 2249 # need to save uniques path
2259 unless ($self->{deny_save}) { 2250 unless ($self->{deny_save}) {
… …
2424 2415
2425our $SAY_CHANNEL = { 2416our $SAY_CHANNEL = {
2426 id => "say", 2417 id => "say",
2427 title => "Map", 2418 title => "Map",
2428 reply => "say ", 2419 reply => "say ",
2429 tooltip => "Things said to and replied from npcs near you and other players on the same map only.", 2420 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2430}; 2421};
2431 2422
2432our $CHAT_CHANNEL = { 2423our $CHAT_CHANNEL = {
2433 id => "chat", 2424 id => "chat",
2434 title => "Chat", 2425 title => "Chat",
… …
2560 2551
2561 $map->load; 2552 $map->load;
2562 $map->load_neighbours; 2553 $map->load_neighbours;
2563 2554
2564 return unless $self->contr->active; 2555 return unless $self->contr->active;
2565 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2566 $self->activate_recursive;
2567 2556
2568 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2557 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2569 $self->enter_map ($map, $x, $y); 2558 $self->enter_map ($map, $x, $y);
2559
2560 # only activate afterwards, to support waiting in hooks
2561 $self->activate_recursive;
2570} 2562}
2571 2563
2572=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2564=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2573 2565
2574Moves the player to the given map-path and coordinates by first freezing 2566Moves the player to the given map-path and coordinates by first freezing
… …
2773 2765
2774=cut 2766=cut
2775 2767
2776# non-persistent channels (usually the info channel) 2768# non-persistent channels (usually the info channel)
2777our %CHANNEL = ( 2769our %CHANNEL = (
2770 "c/motd" => {
2771 id => "infobox",
2772 title => "MOTD",
2773 reply => undef,
2774 tooltip => "The message of the day",
2775 },
2778 "c/identify" => { 2776 "c/identify" => {
2779 id => "infobox", 2777 id => "infobox",
2780 title => "Identify", 2778 title => "Identify",
2781 reply => undef, 2779 reply => undef,
2782 tooltip => "Items recently identified", 2780 tooltip => "Items recently identified",
… …
2809 id => "infobox", 2807 id => "infobox",
2810 title => "Body Parts", 2808 title => "Body Parts",
2811 reply => undef, 2809 reply => undef,
2812 tooltip => "Shows which body parts you posess and are available", 2810 tooltip => "Shows which body parts you posess and are available",
2813 }, 2811 },
2812 "c/statistics" => {
2813 id => "infobox",
2814 title => "Statistics",
2815 reply => undef,
2816 tooltip => "Shows your primary statistics",
2817 },
2814 "c/skills" => { 2818 "c/skills" => {
2815 id => "infobox", 2819 id => "infobox",
2816 title => "Skills", 2820 title => "Skills",
2817 reply => undef, 2821 reply => undef,
2818 tooltip => "Shows your experience per skill and item power", 2822 tooltip => "Shows your experience per skill and item power",
2823 },
2824 "c/shopitems" => {
2825 id => "infobox",
2826 title => "Shop Items",
2827 reply => undef,
2828 tooltip => "Shows the items currently for sale in this shop",
2829 },
2830 "c/resistances" => {
2831 id => "infobox",
2832 title => "Resistances",
2833 reply => undef,
2834 tooltip => "Shows your resistances",
2835 },
2836 "c/pets" => {
2837 id => "infobox",
2838 title => "Pets",
2839 reply => undef,
2840 tooltip => "Shows information abotu your pets/a specific pet",
2841 },
2842 "c/perceiveself" => {
2843 id => "infobox",
2844 title => "Perceive Self",
2845 reply => undef,
2846 tooltip => "You gained detailed knowledge about yourself",
2819 }, 2847 },
2820 "c/uptime" => { 2848 "c/uptime" => {
2821 id => "infobox", 2849 id => "infobox",
2822 title => "Uptime", 2850 title => "Uptime",
2823 reply => undef, 2851 reply => undef,
… …
2833 id => "party", 2861 id => "party",
2834 title => "Party", 2862 title => "Party",
2835 reply => "gsay ", 2863 reply => "gsay ",
2836 tooltip => "Messages and chat related to your party", 2864 tooltip => "Messages and chat related to your party",
2837 }, 2865 },
2866 "c/death" => {
2867 id => "death",
2868 title => "Death",
2869 reply => undef,
2870 tooltip => "Reason for and more info about your most recent death",
2871 },
2872 "c/say" => $SAY_CHANNEL,
2873 "c/chat" => $CHAT_CHANNEL,
2838); 2874);
2839 2875
2840sub cf::client::send_msg { 2876sub cf::client::send_msg {
2841 my ($self, $channel, $msg, $color, @extra) = @_; 2877 my ($self, $channel, $msg, $color, @extra) = @_;
2842 2878
… …
2847 2883
2848 # check predefined channels, for the benefit of C 2884 # check predefined channels, for the benefit of C
2849 if ($CHANNEL{$channel}) { 2885 if ($CHANNEL{$channel}) {
2850 $channel = $CHANNEL{$channel}; 2886 $channel = $CHANNEL{$channel};
2851 2887
2852 $self->ext_msg (channel_info => $channel) 2888 $self->ext_msg (channel_info => $channel);
2853 if $self->can_msg;
2854
2855 $channel = $channel->{id}; 2889 $channel = $channel->{id};
2856 2890
2857 } elsif (ref $channel) { 2891 } elsif (ref $channel) {
2858 # send meta info to client, if not yet sent 2892 # send meta info to client, if not yet sent
2859 unless (exists $self->{channel}{$channel->{id}}) { 2893 unless (exists $self->{channel}{$channel->{id}}) {
2860 $self->{channel}{$channel->{id}} = $channel; 2894 $self->{channel}{$channel->{id}} = $channel;
2861 $self->ext_msg (channel_info => $channel) 2895 $self->ext_msg (channel_info => $channel);
2862 if $self->can_msg;
2863 } 2896 }
2864 2897
2865 $channel = $channel->{id}; 2898 $channel = $channel->{id};
2866 } 2899 }
2867 2900
2868 return unless @extra || length $msg; 2901 return unless @extra || length $msg;
2869 2902
2870 if ($self->can_msg) {
2871 # default colour, mask it out 2903 # default colour, mask it out
2872 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2904 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2873 if $color & cf::NDI_DEF; 2905 if $color & cf::NDI_DEF;
2874 2906
2875 my $pkt = "msg " 2907 my $pkt = "msg "
2876 . $self->{json_coder}->encode ( 2908 . $self->{json_coder}->encode (
2877 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 2909 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2878 ); 2910 );
2879 2911
2880 # try lzf for large packets 2912 # try lzf for large packets
2881 $pkt = "lzf " . Compress::LZF::compress $pkt 2913 $pkt = "lzf " . Compress::LZF::compress $pkt
2882 if 1024 <= length $pkt and $self->{can_lzf}; 2914 if 1024 <= length $pkt and $self->{can_lzf};
2883 2915
2884 # split very large packets 2916 # split very large packets
2885 if (8192 < length $pkt and $self->{can_lzf}) { 2917 if (8192 < length $pkt and $self->{can_lzf}) {
2886 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt; 2918 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2887 $pkt = "frag"; 2919 $pkt = "frag";
2888 } 2920 }
2889 2921
2890 $self->send_packet ($pkt); 2922 $self->send_packet ($pkt);
2891 } else {
2892 if ($color >= 0) {
2893 # replace some tags by gcfclient-compatible ones
2894 for ($msg) {
2895 1 while
2896 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2897 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2898 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2899 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2900 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2901 }
2902
2903 $color &= cf::NDI_COLOR_MASK;
2904
2905 utf8::encode $msg;
2906
2907 if (0 && $msg =~ /\[/) {
2908 # COMMAND/INFO
2909 $self->send_packet ("drawextinfo $color 10 8 $msg")
2910 } else {
2911 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2912 $self->send_packet ("drawinfo $color $msg")
2913 }
2914 }
2915 }
2916} 2923}
2917 2924
2918=item $client->ext_msg ($type, @msg) 2925=item $client->ext_msg ($type, @msg)
2919 2926
2920Sends an ext event to the client. 2927Sends an ext event to the client.
… …
3095The following functions and methods are available within a safe environment: 3102The following functions and methods are available within a safe environment:
3096 3103
3097 cf::object 3104 cf::object
3098 contr pay_amount pay_player map x y force_find force_add destroy 3105 contr pay_amount pay_player map x y force_find force_add destroy
3099 insert remove name archname title slaying race decrease split 3106 insert remove name archname title slaying race decrease split
3107 value
3100 3108
3101 cf::object::player 3109 cf::object::player
3102 player 3110 player
3103 3111
3104 cf::player 3112 cf::player
… …
3110=cut 3118=cut
3111 3119
3112for ( 3120for (
3113 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3121 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3114 insert remove inv nrof name archname title slaying race 3122 insert remove inv nrof name archname title slaying race
3115 decrease split destroy change_exp)], 3123 decrease split destroy change_exp value msg lore send_msg)],
3116 ["cf::object::player" => qw(player)], 3124 ["cf::object::player" => qw(player)],
3117 ["cf::player" => qw(peaceful)], 3125 ["cf::player" => qw(peaceful send_msg)],
3118 ["cf::map" => qw(trigger)], 3126 ["cf::map" => qw(trigger)],
3119) { 3127) {
3120 no strict 'refs'; 3128 no strict 'refs';
3121 my ($pkg, @funs) = @$_; 3129 my ($pkg, @funs) = @$_;
3122 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3130 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
3139 my ($code, %vars) = @_; 3147 my ($code, %vars) = @_;
3140 3148
3141 my $qcode = $code; 3149 my $qcode = $code;
3142 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3150 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3143 $qcode =~ s/\n/\\n/g; 3151 $qcode =~ s/\n/\\n/g;
3152
3153 %vars = (_dummy => 0) unless %vars;
3144 3154
3145 local $_; 3155 local $_;
3146 local @safe::cf::_safe_eval_args = values %vars; 3156 local @safe::cf::_safe_eval_args = values %vars;
3147 3157
3148 my $eval = 3158 my $eval =
… …
3379 3389
3380 warn "finished reloading resource files\n"; 3390 warn "finished reloading resource files\n";
3381} 3391}
3382 3392
3383sub reload_config { 3393sub reload_config {
3394 warn "reloading config file...\n";
3395
3384 open my $fh, "<:utf8", "$CONFDIR/config" 3396 open my $fh, "<:utf8", "$CONFDIR/config"
3385 or return; 3397 or return;
3386 3398
3387 local $/; 3399 local $/;
3388 *CFG = YAML::Load <$fh>; 3400 *CFG = YAML::XS::Load scalar <$fh>;
3389 3401
3390 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3402 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3391 3403
3392 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3404 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3393 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3405 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3397 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3409 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3398 and die "WARNING: m(un)lockall failed: $!\n"; 3410 and die "WARNING: m(un)lockall failed: $!\n";
3399 }; 3411 };
3400 warn $@ if $@; 3412 warn $@ if $@;
3401 } 3413 }
3414
3415 warn "finished reloading resource files\n";
3402} 3416}
3403 3417
3404sub pidfile() { 3418sub pidfile() {
3405 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT 3419 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3406 or die "$PIDFILE: $!"; 3420 or die "$PIDFILE: $!";
… …
3418 3432
3419 seek $fh, 0, 0; 3433 seek $fh, 0, 0;
3420 print $fh $$; 3434 print $fh $$;
3421} 3435}
3422 3436
3437sub main_loop {
3438 warn "EV::loop starting\n";
3439 if (1) {
3440 EV::loop;
3441 }
3442 warn "EV::loop returned\n";
3443 goto &main_loop unless $REALLY_UNLOOP;
3444}
3445
3423sub main { 3446sub main {
3424 cf::init_globals; # initialise logging 3447 cf::init_globals; # initialise logging
3425 3448
3426 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3449 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3427 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3450 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
… …
3430 3453
3431 cf::init_experience; 3454 cf::init_experience;
3432 cf::init_anim; 3455 cf::init_anim;
3433 cf::init_attackmess; 3456 cf::init_attackmess;
3434 cf::init_dynamic; 3457 cf::init_dynamic;
3435 cf::init_block;
3436 3458
3437 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3459 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3438 3460
3439 # we must not ever block the main coroutine 3461 # we must not ever block the main coroutine
3440 local $Coro::idle = sub { 3462 local $Coro::idle = sub {
… …
3466 load_extensions; 3488 load_extensions;
3467 3489
3468 utime time, time, $RUNTIMEFILE; 3490 utime time, time, $RUNTIMEFILE;
3469 3491
3470 # no (long-running) fork's whatsoever before this point(!) 3492 # no (long-running) fork's whatsoever before this point(!)
3493 use POSIX ();
3471 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3494 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3472 3495
3473 (pop @POST_INIT)->(0) while @POST_INIT; 3496 (pop @POST_INIT)->(0) while @POST_INIT;
3474 }; 3497 };
3475 3498
3476 EV::loop; 3499 main_loop;
3477} 3500}
3478 3501
3479############################################################################# 3502#############################################################################
3480# initialisation and cleanup 3503# initialisation and cleanup
3481 3504
… …
3737 clear_package "safe::$_" 3760 clear_package "safe::$_"
3738 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3761 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3739 3762
3740 warn "unloading cf.pm \"a bit\""; 3763 warn "unloading cf.pm \"a bit\"";
3741 delete $INC{"cf.pm"}; 3764 delete $INC{"cf.pm"};
3742 delete $INC{"cf/pod.pm"}; 3765 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3743 3766
3744 # don't, removes xs symbols, too, 3767 # don't, removes xs symbols, too,
3745 # and global variables created in xs 3768 # and global variables created in xs
3746 #clear_package __PACKAGE__; 3769 #clear_package __PACKAGE__;
3747 3770
3748 warn "unload completed, starting to reload now"; 3771 warn "unload completed, starting to reload now";
3749 3772
3750 warn "reloading cf.pm"; 3773 warn "reloading cf.pm";
3751 require cf; 3774 require cf;
3752 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3775 cf::_connect_to_perl_1;
3753 3776
3754 warn "loading config and database again"; 3777 warn "loading config and database again";
3755 cf::reload_config; 3778 cf::reload_config;
3756 3779
3757 warn "loading extensions"; 3780 warn "loading extensions";
… …
3964 LOG llevInfo, "[ABT] [suppressed]\n"; 3987 LOG llevInfo, "[ABT] [suppressed]\n";
3965 } 3988 }
3966} 3989}
3967 3990
3968# load additional modules 3991# load additional modules
3969use cf::pod; 3992require "cf/$_.pm" for @EXTRA_MODULES;
3993cf::_connect_to_perl_2;
3970 3994
3971END { cf::emergency_save } 3995END { cf::emergency_save }
3972 3996
39731 39971
3974 3998

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines