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.219 by root, Sat Feb 17 03:19:44 2007 UTC vs.
Revision 1.442 by root, Sun Aug 31 09:03:31 2008 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation, either version 3 of the License, or
9# (at your option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>.
18#
19# The authors can be reached via e-mail to <support@deliantra.net>
20#
21
1package cf; 22package cf;
2 23
24use 5.10.0;
3use utf8; 25use utf8;
4use strict; 26use strict "vars", "subs";
5 27
6use Symbol; 28use Symbol;
7use List::Util; 29use List::Util;
8use Storable; 30use Socket;
31use EV;
9use Opcode; 32use Opcode;
10use Safe; 33use Safe;
11use Safe::Hole; 34use Safe::Hole;
35use Storable ();
12 36
13use Coro 3.5 (); 37use Coro ();
38use Coro::State;
39use Coro::Handle;
40use Coro::EV;
14use Coro::Event; 41use Coro::AnyEvent;
15use Coro::Timer; 42use Coro::Timer;
16use Coro::Signal; 43use Coro::Signal;
17use Coro::Semaphore; 44use Coro::Semaphore;
45use Coro::AnyEvent;
18use Coro::AIO; 46use Coro::AIO;
47use Coro::BDB 1.6;
48use Coro::Storable;
49use Coro::Util ();
19 50
51use JSON::XS 2.01 ();
20use BDB (); 52use BDB ();
21use Data::Dumper; 53use Data::Dumper;
22use Digest::MD5; 54use Digest::MD5;
23use Fcntl; 55use Fcntl;
56use YAML ();
24use IO::AIO 2.32 (); 57use IO::AIO ();
25use YAML::Syck ();
26use Time::HiRes; 58use Time::HiRes;
27use Compress::LZF; 59use Compress::LZF;
60use Digest::MD5 ();
28 61
62AnyEvent::detect;
63
64# configure various modules to our taste
65#
66$Storable::canonical = 1; # reduce rsync transfers
67Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
29Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 68Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
30 69
31use Event; $Event::Eval = 1; # no idea why this is required, but it is 70$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
32 71
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 72sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34
35# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
36$YAML::Syck::ImplicitUnicode = 1;
37
38$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
39 73
40our %COMMAND = (); 74our %COMMAND = ();
41our %COMMAND_TIME = (); 75our %COMMAND_TIME = ();
42 76
43our @EXTS = (); # list of extension package names 77our @EXTS = (); # list of extension package names
44our %EXTCMD = (); 78our %EXTCMD = ();
79our %EXTICMD = ();
45our %EXT_CORO = (); # coroutines bound to extensions 80our %EXT_CORO = (); # coroutines bound to extensions
46our %EXT_MAP = (); # pluggable maps 81our %EXT_MAP = (); # pluggable maps
47 82
83our $RELOAD; # number of reloads so far
48our @EVENT; 84our @EVENT;
49our $LIBDIR = datadir . "/ext";
50 85
51our $TICK = MAX_TIME * 1e-6; 86our $CONFDIR = confdir;
52our $TICK_WATCHER; 87our $DATADIR = datadir;
53our $AIO_POLL_WATCHER; 88our $LIBDIR = "$DATADIR/ext";
89our $PODDIR = "$DATADIR/pod";
90our $MAPDIR = "$DATADIR/" . mapdir;
91our $LOCALDIR = localdir;
92our $TMPDIR = "$LOCALDIR/" . tmpdir;
93our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
94our $PLAYERDIR = "$LOCALDIR/" . playerdir;
95our $RANDOMDIR = "$LOCALDIR/random";
96our $BDBDIR = "$LOCALDIR/db";
97our %RESOURCE;
98
99our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
54our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 100our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
55our $NEXT_TICK; 101our $NEXT_TICK;
56our $NOW;
57our $USE_FSYNC = 1; # use fsync to write maps - default off 102our $USE_FSYNC = 1; # use fsync to write maps - default off
58 103
104our $BDB_DEADLOCK_WATCHER;
105our $BDB_CHECKPOINT_WATCHER;
59our $BDB_POLL_WATCHER; 106our $BDB_TRICKLE_WATCHER;
60our $DB_ENV; 107our $DB_ENV;
61 108
62our %CFG; 109our %CFG;
63 110
64our $UPTIME; $UPTIME ||= time; 111our $UPTIME; $UPTIME ||= time;
65our $RUNTIME; 112our $RUNTIME;
113our $NOW;
66 114
67our %PLAYER; # all users 115our (%PLAYER, %PLAYER_LOADING); # all users
68our %MAP; # all maps 116our (%MAP, %MAP_LOADING ); # all maps
69our $LINK_MAP; # the special {link} map, which is always available 117our $LINK_MAP; # the special {link} map, which is always available
70our $RANDOM_MAPS = cf::localdir . "/random";
71our $BDB_ENV_DIR = cf::localdir . "/db";
72
73our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
74our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
75 118
76# used to convert map paths into valid unix filenames by replacing / by ∕ 119# used to convert map paths into valid unix filenames by replacing / by ∕
77our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 120our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
78 121
122our $LOAD; # a number between 0 (idle) and 1 (too many objects)
123our $LOADAVG; # same thing, but with alpha-smoothing
124our $JITTER; # average jitter
125our $TICK_START; # for load detecting purposes
126
79binmode STDOUT; 127binmode STDOUT;
80binmode STDERR; 128binmode STDERR;
81 129
82# read virtual server time, if available 130# read virtual server time, if available
83unless ($RUNTIME || !-e cf::localdir . "/runtime") { 131unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
84 open my $fh, "<", cf::localdir . "/runtime" 132 open my $fh, "<", "$LOCALDIR/runtime"
85 or die "unable to read runtime file: $!"; 133 or die "unable to read runtime file: $!";
86 $RUNTIME = <$fh> + 0.; 134 $RUNTIME = <$fh> + 0.;
87} 135}
88 136
89mkdir cf::localdir; 137mkdir $_
90mkdir cf::localdir . "/" . cf::playerdir; 138 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
91mkdir cf::localdir . "/" . cf::tmpdir;
92mkdir cf::localdir . "/" . cf::uniquedir;
93mkdir $RANDOM_MAPS;
94mkdir $BDB_ENV_DIR;
95 139
96our $EMERGENCY_POSITION; 140our $EMERGENCY_POSITION;
97 141
98sub cf::map::normalise; 142sub cf::map::normalise;
99 143
… …
110=item $cf::RUNTIME 154=item $cf::RUNTIME
111 155
112The time this server has run, starts at 0 and is increased by $cf::TICK on 156The time this server has run, starts at 0 and is increased by $cf::TICK on
113every server tick. 157every server tick.
114 158
115=item $cf::LIBDIR 159=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
160$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
161$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
116 162
117The perl library directory, where extensions and cf-specific modules can 163Various directories - "/etc", read-only install directory, perl-library
118be found. It will be added to C<@INC> automatically. 164directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
165unique-items directory, player file directory, random maps directory and
166database environment.
119 167
120=item $cf::NOW 168=item $cf::NOW
121 169
122The time of the last (current) server tick. 170The time of the last (current) server tick.
123 171
124=item $cf::TICK 172=item $cf::TICK
125 173
126The interval between server ticks, in seconds. 174The interval between server ticks, in seconds.
127 175
176=item $cf::LOADAVG
177
178The current CPU load on the server (alpha-smoothed), as a value between 0
179(none) and 1 (overloaded), indicating how much time is spent on processing
180objects per tick. Healthy values are < 0.5.
181
182=item $cf::LOAD
183
184The raw value load value from the last tick.
185
128=item %cf::CFG 186=item %cf::CFG
129 187
130Configuration for the server, loaded from C</etc/crossfire/config>, or 188Configuration for the server, loaded from C</etc/deliantra-server/config>, or
131from wherever your confdir points to. 189from wherever your confdir points to.
132 190
133=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 191=item cf::wait_for_tick, cf::wait_for_tick_begin
134 192
135These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK) 193These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
136or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick 194returns directly I<after> the tick processing (and consequently, can only wake one process
137processing has been done. Call C<< ->wait >> on them to maximise the 195per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
138window of cpu time available, or simply to synchronise to the server tick. 196
197=item @cf::INVOKE_RESULTS
198
199This array contains the results of the last C<invoke ()> call. When
200C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
201that call.
139 202
140=back 203=back
141 204
142=cut 205=cut
143 206
144BEGIN { 207BEGIN {
145 *CORE::GLOBAL::warn = sub { 208 *CORE::GLOBAL::warn = sub {
146 my $msg = join "", @_; 209 my $msg = join "", @_;
147 utf8::encode $msg;
148 210
149 $msg .= "\n" 211 $msg .= "\n"
150 unless $msg =~ /\n$/; 212 unless $msg =~ /\n$/;
151 213
214 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
215
152 LOG llevError, $msg; 216 LOG llevError, $msg;
153 }; 217 };
154} 218}
219
220$Coro::State::DIEHOOK = sub {
221 return unless $^S eq 0; # "eq", not "=="
222
223 if ($Coro::current == $Coro::main) {#d#
224 warn "DIEHOOK called in main context, Coro bug?\n";#d#
225 return;#d#
226 }#d#
227
228 # kill coroutine otherwise
229 warn Carp::longmess $_[0];
230 Coro::terminate
231};
232
233$SIG{__DIE__} = sub { }; #d#?
155 234
156@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 235@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
157@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 236@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
158@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 237@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
159@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 238@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
160@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 239@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
240@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
161@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 241@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
162 242
163# we bless all objects into (empty) derived classes to force a method lookup 243# we bless all objects into (empty) derived classes to force a method lookup
164# within the Safe compartment. 244# within the Safe compartment.
165for my $pkg (qw( 245for my $pkg (qw(
166 cf::global cf::attachable 246 cf::global cf::attachable
167 cf::object cf::object::player 247 cf::object cf::object::player
168 cf::client cf::player 248 cf::client cf::player
169 cf::arch cf::living 249 cf::arch cf::living
250 cf::map cf::mapspace
170 cf::map cf::party cf::region 251 cf::party cf::region
171)) { 252)) {
172 no strict 'refs';
173 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 253 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
174} 254}
175 255
176$Event::DIED = sub { 256$EV::DIED = sub {
177 warn "error in event callback: @_"; 257 warn "error in event callback: @_";
178}; 258};
259
260#############################################################################
179 261
180=head2 UTILITY FUNCTIONS 262=head2 UTILITY FUNCTIONS
181 263
182=over 4 264=over 4
183 265
… …
202 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 284 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
203 $d 285 $d
204 } || "[unable to dump $_[0]: '$@']"; 286 } || "[unable to dump $_[0]: '$@']";
205} 287}
206 288
207use JSON::Syck (); # TODO# replace by JSON::PC once working
208
209=item $ref = cf::from_json $json 289=item $ref = cf::decode_json $json
210 290
211Converts a JSON string into the corresponding perl data structure. 291Converts a JSON string into the corresponding perl data structure.
212 292
213=cut
214
215sub from_json($) {
216 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
217 JSON::Syck::Load $_[0]
218}
219
220=item $json = cf::to_json $ref 293=item $json = cf::encode_json $ref
221 294
222Converts a perl data structure into its JSON representation. 295Converts a perl data structure into its JSON representation.
223 296
224=cut 297=cut
225 298
226sub to_json($) { 299our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
227 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 300
228 JSON::Syck::Dump $_[0] 301sub encode_json($) { $json_coder->encode ($_[0]) }
229} 302sub decode_json($) { $json_coder->decode ($_[0]) }
230 303
231=item cf::lock_wait $string 304=item cf::lock_wait $string
232 305
233Wait until the given lock is available. See cf::lock_acquire. 306Wait until the given lock is available. See cf::lock_acquire.
234 307
… …
237Wait until the given lock is available and then acquires it and returns 310Wait until the given lock is available and then acquires it and returns
238a Coro::guard object. If the guard object gets destroyed (goes out of scope, 311a Coro::guard object. If the guard object gets destroyed (goes out of scope,
239for example when the coroutine gets canceled), the lock is automatically 312for example when the coroutine gets canceled), the lock is automatically
240returned. 313returned.
241 314
315Locks are *not* recursive, locking from the same coro twice results in a
316deadlocked coro.
317
242Lock names should begin with a unique identifier (for example, cf::map::find 318Lock names should begin with a unique identifier (for example, cf::map::find
243uses map_find and cf::map::load uses map_load). 319uses map_find and cf::map::load uses map_load).
244 320
321=item $locked = cf::lock_active $string
322
323Return true if the lock is currently active, i.e. somebody has locked it.
324
245=cut 325=cut
246 326
247our %LOCK; 327our %LOCK;
328our %LOCKER;#d#
248 329
249sub lock_wait($) { 330sub lock_wait($) {
250 my ($key) = @_; 331 my ($key) = @_;
332
333 if ($LOCKER{$key} == $Coro::current) {#d#
334 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
335 return;#d#
336 }#d#
251 337
252 # wait for lock, if any 338 # wait for lock, if any
253 while ($LOCK{$key}) { 339 while ($LOCK{$key}) {
254 push @{ $LOCK{$key} }, $Coro::current; 340 push @{ $LOCK{$key} }, $Coro::current;
255 Coro::schedule; 341 Coro::schedule;
… …
261 347
262 # wait, to be sure we are not locked 348 # wait, to be sure we are not locked
263 lock_wait $key; 349 lock_wait $key;
264 350
265 $LOCK{$key} = []; 351 $LOCK{$key} = [];
352 $LOCKER{$key} = $Coro::current;#d#
266 353
267 Coro::guard { 354 Coro::guard {
355 delete $LOCKER{$key};#d#
268 # wake up all waiters, to be on the safe side 356 # wake up all waiters, to be on the safe side
269 $_->ready for @{ delete $LOCK{$key} }; 357 $_->ready for @{ delete $LOCK{$key} };
270 } 358 }
271} 359}
272 360
361sub lock_active($) {
362 my ($key) = @_;
363
364 ! ! $LOCK{$key}
365}
366
273sub freeze_mainloop { 367sub freeze_mainloop {
274 return unless $TICK_WATCHER->is_active; 368 tick_inhibit_inc;
275 369
276 my $guard = Coro::guard { 370 Coro::guard \&tick_inhibit_dec;
277 $TICK_WATCHER->start; 371}
372
373=item cf::periodic $interval, $cb
374
375Like EV::periodic, but randomly selects a starting point so that the actions
376get spread over timer.
377
378=cut
379
380sub periodic($$) {
381 my ($interval, $cb) = @_;
382
383 my $start = rand List::Util::min 180, $interval;
384
385 EV::periodic $start, $interval, 0, $cb
386}
387
388=item cf::get_slot $time[, $priority[, $name]]
389
390Allocate $time seconds of blocking CPU time at priority C<$priority>:
391This call blocks and returns only when you have at least C<$time> seconds
392of cpu time till the next tick. The slot is only valid till the next cede.
393
394The optional C<$name> can be used to identify the job to run. It might be
395used for statistical purposes and should identify the same time-class.
396
397Useful for short background jobs.
398
399=cut
400
401our @SLOT_QUEUE;
402our $SLOT_QUEUE;
403
404$SLOT_QUEUE->cancel if $SLOT_QUEUE;
405$SLOT_QUEUE = Coro::async {
406 $Coro::current->desc ("timeslot manager");
407
408 my $signal = new Coro::Signal;
409
410 while () {
411 next_job:
412 my $avail = cf::till_tick;
413 if ($avail > 0.01) {
414 for (0 .. $#SLOT_QUEUE) {
415 if ($SLOT_QUEUE[$_][0] < $avail) {
416 my $job = splice @SLOT_QUEUE, $_, 1, ();
417 $job->[2]->send;
418 Coro::cede;
419 goto next_job;
420 }
421 }
422 }
423
424 if (@SLOT_QUEUE) {
425 # we do not use wait_for_tick() as it returns immediately when tick is inactive
426 push @cf::WAIT_FOR_TICK, $signal;
427 $signal->wait;
428 } else {
429 Coro::schedule;
430 }
278 }; 431 }
279 $TICK_WATCHER->stop; 432};
280 $guard 433
434sub get_slot($;$$) {
435 return if tick_inhibit || $Coro::current == $Coro::main;
436
437 my ($time, $pri, $name) = @_;
438
439 $time = $TICK * .6 if $time > $TICK * .6;
440 my $sig = new Coro::Signal;
441
442 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
443 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
444 $SLOT_QUEUE->ready;
445 $sig->wait;
281} 446}
282 447
283=item cf::async { BLOCK } 448=item cf::async { BLOCK }
284 449
285Currently the same as Coro::async_pool, meaning you cannot use 450Currently the same as Coro::async_pool, meaning you cannot use
… …
290 455
291BEGIN { *async = \&Coro::async_pool } 456BEGIN { *async = \&Coro::async_pool }
292 457
293=item cf::sync_job { BLOCK } 458=item cf::sync_job { BLOCK }
294 459
295The design of crossfire+ requires that the main coro ($Coro::main) is 460The design of Deliantra requires that the main coroutine ($Coro::main)
296always able to handle events or runnable, as crossfire+ is only partly 461is always able to handle events or runnable, as Deliantra is only
297reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 462partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
463acceptable.
298 464
299If it must be done, put the blocking parts into C<sync_job>. This will run 465If it must be done, put the blocking parts into C<sync_job>. This will run
300the given BLOCK in another coroutine while waiting for the result. The 466the given BLOCK in another coroutine while waiting for the result. The
301server will be frozen during this time, so the block should either finish 467server will be frozen during this time, so the block should either finish
302fast or be very important. 468fast or be very important.
… …
305 471
306sub sync_job(&) { 472sub sync_job(&) {
307 my ($job) = @_; 473 my ($job) = @_;
308 474
309 if ($Coro::current == $Coro::main) { 475 if ($Coro::current == $Coro::main) {
476 my $time = EV::time;
477
310 # this is the main coro, too bad, we have to block 478 # this is the main coro, too bad, we have to block
311 # till the operation succeeds, freezing the server :/ 479 # till the operation succeeds, freezing the server :/
312 480
313 # TODO: use suspend/resume instead 481 LOG llevError, Carp::longmess "sync job";#d#
314 # (but this is cancel-safe) 482
315 my $freeze_guard = freeze_mainloop; 483 my $freeze_guard = freeze_mainloop;
316 484
317 my $busy = 1; 485 my $busy = 1;
318 my @res; 486 my @res;
319 487
320 (async { 488 (async {
489 $Coro::current->desc ("sync job coro");
321 @res = eval { $job->() }; 490 @res = eval { $job->() };
322 warn $@ if $@; 491 warn $@ if $@;
323 undef $busy; 492 undef $busy;
324 })->prio (Coro::PRIO_MAX); 493 })->prio (Coro::PRIO_MAX);
325 494
326 while ($busy) { 495 while ($busy) {
327 Coro::cede or Event::one_event; 496 if (Coro::nready) {
497 Coro::cede_notself;
498 } else {
499 EV::loop EV::LOOP_ONESHOT;
328 } 500 }
501 }
502
503 my $time = EV::time - $time;
504
505 $TICK_START += $time; # do not account sync jobs to server load
329 506
330 wantarray ? @res : $res[0] 507 wantarray ? @res : $res[0]
331 } else { 508 } else {
332 # we are in another coroutine, how wonderful, everything just works 509 # we are in another coroutine, how wonderful, everything just works
333 510
… …
353 $EXT_CORO{$coro+0} = $coro; 530 $EXT_CORO{$coro+0} = $coro;
354 531
355 $coro 532 $coro
356} 533}
357 534
358sub write_runtime { 535=item fork_call { }, $args
359 my $guard = cf::lock_acquire "write_runtime";
360 536
361 my $runtime = cf::localdir . "/runtime"; 537Executes the given code block with the given arguments in a seperate
538process, returning the results. Everything must be serialisable with
539Coro::Storable. May, of course, block. Note that the executed sub may
540never block itself or use any form of event handling.
362 541
363 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 542=cut
364 or return;
365 543
366 my $value = $cf::RUNTIME + 90 + 10; 544sub fork_call(&@) {
367 # 10 is the runtime save interval, for a monotonic clock 545 my ($cb, @args) = @_;
368 # 60 allows for the watchdog to kill the server.
369 546
370 (aio_write $fh, 0, (length $value), $value, 0) <= 0 547 # we seemingly have to make a local copy of the whole thing,
371 and return; 548 # otherwise perl prematurely frees the stuff :/
549 # TODO: investigate and fix (likely this will be rather laborious)
372 550
373 # always fsync - this file is important 551 my @res = Coro::Util::fork_eval {
374 aio_fsync $fh 552 reset_signals;
375 and return; 553 &$cb
554 }, @args;
376 555
377 close $fh 556 wantarray ? @res : $res[-1]
378 or return; 557}
379 558
380 aio_rename "$runtime~", $runtime 559=item $coin = coin_from_name $name
381 and return;
382 560
561=cut
562
563our %coin_alias = (
564 "silver" => "silvercoin",
565 "silvercoin" => "silvercoin",
566 "silvercoins" => "silvercoin",
567 "gold" => "goldcoin",
568 "goldcoin" => "goldcoin",
569 "goldcoins" => "goldcoin",
570 "platinum" => "platinacoin",
571 "platinumcoin" => "platinacoin",
572 "platinumcoins" => "platinacoin",
573 "platina" => "platinacoin",
574 "platinacoin" => "platinacoin",
575 "platinacoins" => "platinacoin",
576 "royalty" => "royalty",
577 "royalties" => "royalty",
578);
579
580sub coin_from_name($) {
581 $coin_alias{$_[0]}
582 ? cf::arch::find $coin_alias{$_[0]}
583 : undef
584}
585
586=item $value = cf::db_get $family => $key
587
588Returns a single value from the environment database.
589
590=item cf::db_put $family => $key => $value
591
592Stores the given C<$value> in the family. It can currently store binary
593data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
594
595=item $db = cf::db_table "name"
596
597Create and/or open a new database table. The string must not be "db" and must be unique
598within each server.
599
600=cut
601
602sub db_table($) {
603 my ($name) = @_;
604 my $db = BDB::db_create $DB_ENV;
605
606 eval {
607 $db->set_flags (BDB::CHKSUM);
608
609 utf8::encode $name;
610 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
611 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
612 cf::cleanup "db_open(db): $!" if $!;
613 };
614 cf::cleanup "db_open(db): $@" if $@;
615
616 $db
617}
618
619our $DB;
620
621sub db_init {
622 cf::sync_job {
623 $DB ||= db_table "db";
624 };
625}
626
627sub db_get($$) {
628 my $key = "$_[0]/$_[1]";
629
630 cf::sync_job {
631 BDB::db_get $DB, undef, $key, my $data;
632
633 $! ? ()
634 : $data
383 1 635 }
636}
637
638sub db_put($$$) {
639 BDB::dbreq_pri 4;
640 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
641}
642
643=item cf::cache $id => [$paths...], $processversion => $process
644
645Generic caching function that returns the value of the resource $id,
646caching and regenerating as required.
647
648This function can block.
649
650=cut
651
652sub cache {
653 my ($id, $src, $processversion, $process) = @_;
654
655 my $meta =
656 join "\x00",
657 $processversion,
658 map {
659 aio_stat $_
660 and Carp::croak "$_: $!";
661
662 ($_, (stat _)[7,9])
663 } @$src;
664
665 my $dbmeta = db_get cache => "$id/meta";
666 if ($dbmeta ne $meta) {
667 # changed, we may need to process
668
669 my @data;
670 my $md5;
671
672 for (0 .. $#$src) {
673 0 <= aio_load $src->[$_], $data[$_]
674 or Carp::croak "$src->[$_]: $!";
675 }
676
677 # if processing is expensive, check
678 # checksum first
679 if (1) {
680 $md5 =
681 join "\x00",
682 $processversion,
683 map {
684 cf::cede_to_tick;
685 ($src->[$_], Digest::MD5::md5_hex $data[$_])
686 } 0.. $#$src;
687
688
689 my $dbmd5 = db_get cache => "$id/md5";
690 if ($dbmd5 eq $md5) {
691 db_put cache => "$id/meta", $meta;
692
693 return db_get cache => "$id/data";
694 }
695 }
696
697 my $t1 = Time::HiRes::time;
698 my $data = $process->(\@data);
699 my $t2 = Time::HiRes::time;
700
701 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
702
703 db_put cache => "$id/data", $data;
704 db_put cache => "$id/md5" , $md5;
705 db_put cache => "$id/meta", $meta;
706
707 return $data;
708 }
709
710 db_get cache => "$id/data"
711}
712
713=item cf::datalog type => key => value, ...
714
715Log a datalog packet of the given type with the given key-value pairs.
716
717=cut
718
719sub datalog($@) {
720 my ($type, %kv) = @_;
721 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
384} 722}
385 723
386=back 724=back
387 725
388=cut 726=cut
… …
395attach callbacks/event handlers (a collection of which is called an "attachment") 733attach callbacks/event handlers (a collection of which is called an "attachment")
396to it. All such attachable objects support the following methods. 734to it. All such attachable objects support the following methods.
397 735
398In the following description, CLASS can be any of C<global>, C<object> 736In the following description, CLASS can be any of C<global>, C<object>
399C<player>, C<client> or C<map> (i.e. the attachable objects in 737C<player>, C<client> or C<map> (i.e. the attachable objects in
400crossfire+). 738Deliantra).
401 739
402=over 4 740=over 4
403 741
404=item $attachable->attach ($attachment, key => $value...) 742=item $attachable->attach ($attachment, key => $value...)
405 743
… …
568 $registry = $CB_TYPE[$object_type] ||= []; 906 $registry = $CB_TYPE[$object_type] ||= [];
569 907
570 } elsif ($type eq "subtype") { 908 } elsif ($type eq "subtype") {
571 defined $object_type or Carp::croak "subtype specified without type"; 909 defined $object_type or Carp::croak "subtype specified without type";
572 my $object_subtype = shift @arg; 910 my $object_subtype = shift @arg;
573 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 911 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
574 912
575 } elsif ($type eq "package") { 913 } elsif ($type eq "package") {
576 my $pkg = shift @arg; 914 my $pkg = shift @arg;
577 915
578 while (my ($name, $id) = each %cb_id) { 916 while (my ($name, $id) = each %cb_id) {
… …
607 _attach $registry, $klass, @attach; 945 _attach $registry, $klass, @attach;
608 } 946 }
609 947
610 $obj->{$name} = \%arg; 948 $obj->{$name} = \%arg;
611 } else { 949 } else {
612 warn "object uses attachment '$name' that is not available, postponing.\n"; 950 warn "object uses attachment '$name' which is not available, postponing.\n";
613 } 951 }
614 952
615 $obj->{_attachment}{$name} = undef; 953 $obj->{_attachment}{$name} = undef;
616} 954}
617 955
… …
619 if (ref $_[0]) { 957 if (ref $_[0]) {
620 _object_attach @_; 958 _object_attach @_;
621 } else { 959 } else {
622 _attach shift->_attach_registry, @_; 960 _attach shift->_attach_registry, @_;
623 } 961 }
962 _recalc_want;
624}; 963};
625 964
626# all those should be optimised 965# all those should be optimised
627sub cf::attachable::detach { 966sub cf::attachable::detach {
628 my ($obj, $name) = @_; 967 my ($obj, $name) = @_;
… …
631 delete $obj->{_attachment}{$name}; 970 delete $obj->{_attachment}{$name};
632 reattach ($obj); 971 reattach ($obj);
633 } else { 972 } else {
634 Carp::croak "cannot, currently, detach class attachments"; 973 Carp::croak "cannot, currently, detach class attachments";
635 } 974 }
975 _recalc_want;
636}; 976};
637 977
638sub cf::attachable::attached { 978sub cf::attachable::attached {
639 my ($obj, $name) = @_; 979 my ($obj, $name) = @_;
640 980
… …
655 "; 995 ";
656 die if $@; 996 die if $@;
657} 997}
658 998
659our $override; 999our $override;
660our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 1000our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
661 1001
662sub override { 1002sub override {
663 $override = 1; 1003 $override = 1;
664 @invoke_results = (); 1004 @INVOKE_RESULTS = (@_);
665} 1005}
666 1006
667sub do_invoke { 1007sub do_invoke {
668 my $event = shift; 1008 my $event = shift;
669 my $callbacks = shift; 1009 my $callbacks = shift;
670 1010
671 @invoke_results = (); 1011 @INVOKE_RESULTS = ();
672 1012
673 local $override; 1013 local $override;
674 1014
675 for (@$callbacks) { 1015 for (@$callbacks) {
676 eval { &{$_->[1]} }; 1016 eval { &{$_->[1]} };
… …
685 } 1025 }
686 1026
687 0 1027 0
688} 1028}
689 1029
690=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1030=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
691 1031
692=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1032=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
693 1033
694Generate an object-specific event with the given arguments. 1034Generate an object-specific event with the given arguments.
695 1035
696This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 1036This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
697removed in future versions), and there is no public API to access override 1037removed in future versions), and there is no public API to access override
698results (if you must, access C<@cf::invoke_results> directly). 1038results (if you must, access C<@cf::INVOKE_RESULTS> directly).
699 1039
700=back 1040=back
701 1041
702=cut 1042=cut
703 1043
704############################################################################# 1044#############################################################################
705# object support 1045# object support
1046
1047sub _object_equal($$);
1048sub _object_equal($$) {
1049 my ($a, $b) = @_;
1050
1051 return 0 unless (ref $a) eq (ref $b);
1052
1053 if ("HASH" eq ref $a) {
1054 my @ka = keys %$a;
1055 my @kb = keys %$b;
1056
1057 return 0 if @ka != @kb;
1058
1059 for (0 .. $#ka) {
1060 return 0 unless $ka[$_] eq $kb[$_];
1061 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1062 }
1063
1064 } elsif ("ARRAY" eq ref $a) {
1065
1066 return 0 if @$a != @$b;
1067
1068 for (0 .. $#$a) {
1069 return 0 unless _object_equal $a->[$_], $b->[$_];
1070 }
1071
1072 } elsif ($a ne $b) {
1073 return 0;
1074 }
1075
1076 1
1077}
1078
1079our $SLOW_MERGES;#d#
1080sub _can_merge {
1081 my ($ob1, $ob2) = @_;
1082
1083 ++$SLOW_MERGES;#d#
1084
1085 # we do the slow way here
1086 return _object_equal $ob1, $ob2
1087}
706 1088
707sub reattach { 1089sub reattach {
708 # basically do the same as instantiate, without calling instantiate 1090 # basically do the same as instantiate, without calling instantiate
709 my ($obj) = @_; 1091 my ($obj) = @_;
710 1092
1093 # no longer needed after getting rid of delete_package?
711 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1094 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
712 1095
713 my $registry = $obj->registry; 1096 my $registry = $obj->registry;
714 1097
715 @$registry = (); 1098 @$registry = ();
716 1099
… …
731cf::attachable->attach ( 1114cf::attachable->attach (
732 prio => -1000000, 1115 prio => -1000000,
733 on_instantiate => sub { 1116 on_instantiate => sub {
734 my ($obj, $data) = @_; 1117 my ($obj, $data) = @_;
735 1118
736 $data = from_json $data; 1119 $data = decode_json $data;
737 1120
738 for (@$data) { 1121 for (@$data) {
739 my ($name, $args) = @$_; 1122 my ($name, $args) = @$_;
740 1123
741 $obj->attach ($name, %{$args || {} }); 1124 $obj->attach ($name, %{$args || {} });
… …
757sub object_freezer_save { 1140sub object_freezer_save {
758 my ($filename, $rdata, $objs) = @_; 1141 my ($filename, $rdata, $objs) = @_;
759 1142
760 sync_job { 1143 sync_job {
761 if (length $$rdata) { 1144 if (length $$rdata) {
1145 utf8::decode (my $decname = $filename);
762 warn sprintf "saving %s (%d,%d)\n", 1146 warn sprintf "saving %s (%d,%d)\n",
763 $filename, length $$rdata, scalar @$objs; 1147 $decname, length $$rdata, scalar @$objs;
764 1148
765 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1149 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
766 chmod SAVE_MODE, $fh; 1150 aio_chmod $fh, SAVE_MODE;
767 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1151 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
768 aio_fsync $fh if $cf::USE_FSYNC; 1152 aio_fsync $fh if $cf::USE_FSYNC;
769 close $fh; 1153 aio_close $fh;
770 1154
771 if (@$objs) { 1155 if (@$objs) {
772 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1156 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
773 chmod SAVE_MODE, $fh; 1157 aio_chmod $fh, SAVE_MODE;
774 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1158 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
775 aio_write $fh, 0, (length $data), $data, 0; 1159 aio_write $fh, 0, (length $data), $data, 0;
776 aio_fsync $fh if $cf::USE_FSYNC; 1160 aio_fsync $fh if $cf::USE_FSYNC;
777 close $fh; 1161 aio_close $fh;
778 aio_rename "$filename.pst~", "$filename.pst"; 1162 aio_rename "$filename.pst~", "$filename.pst";
779 } 1163 }
780 } else { 1164 } else {
781 aio_unlink "$filename.pst"; 1165 aio_unlink "$filename.pst";
782 } 1166 }
… …
787 } 1171 }
788 } else { 1172 } else {
789 aio_unlink $filename; 1173 aio_unlink $filename;
790 aio_unlink "$filename.pst"; 1174 aio_unlink "$filename.pst";
791 } 1175 }
792 } 1176 };
793} 1177}
794 1178
795sub object_freezer_as_string { 1179sub object_freezer_as_string {
796 my ($rdata, $objs) = @_; 1180 my ($rdata, $objs) = @_;
797 1181
… …
809 or return; 1193 or return;
810 1194
811 unless (aio_stat "$filename.pst") { 1195 unless (aio_stat "$filename.pst") {
812 (aio_load "$filename.pst", $av) >= 0 1196 (aio_load "$filename.pst", $av) >= 0
813 or return; 1197 or return;
1198
814 $av = eval { (Storable::thaw $av)->{objs} }; 1199 my $st = eval { Coro::Storable::thaw $av };
1200 $av = $st->{objs};
815 } 1201 }
816 1202
1203 utf8::decode (my $decname = $filename);
817 warn sprintf "loading %s (%d)\n", 1204 warn sprintf "loading %s (%d,%d)\n",
818 $filename, length $data, scalar @{$av || []};#d# 1205 $decname, length $data, scalar @{$av || []};
1206
819 return ($data, $av); 1207 ($data, $av)
820} 1208}
1209
1210=head2 COMMAND CALLBACKS
1211
1212=over 4
1213
1214=cut
821 1215
822############################################################################# 1216#############################################################################
823# command handling &c 1217# command handling &c
824 1218
825=item cf::register_command $name => \&callback($ob,$args); 1219=item cf::register_command $name => \&callback($ob,$args);
… …
838 push @{ $COMMAND{$name} }, [$caller, $cb]; 1232 push @{ $COMMAND{$name} }, [$caller, $cb];
839} 1233}
840 1234
841=item cf::register_extcmd $name => \&callback($pl,$packet); 1235=item cf::register_extcmd $name => \&callback($pl,$packet);
842 1236
843Register a callbackf ro execution when the client sends an extcmd packet. 1237Register a callback for execution when the client sends an (synchronous)
1238extcmd packet. Ext commands will be processed in the order they are
1239received by the server, like other user commands. The first argument is
1240the logged-in player. Ext commands can only be processed after a player
1241has logged in successfully.
844 1242
845If the callback returns something, it is sent back as if reply was being 1243If the callback returns something, it is sent back as if reply was being
846called. 1244called.
847 1245
1246=item cf::register_exticmd $name => \&callback($ns,$packet);
1247
1248Register a callback for execution when the client sends an (asynchronous)
1249exticmd packet. Exti commands are processed by the server as soon as they
1250are received, i.e. out of order w.r.t. other commands. The first argument
1251is a client socket. Exti commands can be received anytime, even before
1252log-in.
1253
1254If the callback returns something, it is sent back as if reply was being
1255called.
1256
848=cut 1257=cut
849 1258
850sub register_extcmd { 1259sub register_extcmd {
851 my ($name, $cb) = @_; 1260 my ($name, $cb) = @_;
852 1261
853 $EXTCMD{$name} = $cb; 1262 $EXTCMD{$name} = $cb;
1263}
1264
1265sub register_exticmd {
1266 my ($name, $cb) = @_;
1267
1268 $EXTICMD{$name} = $cb;
854} 1269}
855 1270
856cf::player->attach ( 1271cf::player->attach (
857 on_command => sub { 1272 on_command => sub {
858 my ($pl, $name, $params) = @_; 1273 my ($pl, $name, $params) = @_;
… …
867 cf::override; 1282 cf::override;
868 }, 1283 },
869 on_extcmd => sub { 1284 on_extcmd => sub {
870 my ($pl, $buf) = @_; 1285 my ($pl, $buf) = @_;
871 1286
872 my $msg = eval { from_json $buf }; 1287 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
873 1288
874 if (ref $msg) { 1289 if (ref $msg) {
1290 my ($type, $reply, @payload) =
1291 "ARRAY" eq ref $msg
1292 ? @$msg
1293 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1294
1295 my @reply;
1296
875 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1297 if (my $cb = $EXTCMD{$type}) {
876 if (my %reply = $cb->($pl, $msg)) { 1298 @reply = $cb->($pl, @payload);
877 $pl->ext_reply ($msg->{msgid}, %reply);
878 }
879 } 1299 }
1300
1301 $pl->ext_reply ($reply, @reply)
1302 if $reply;
1303
880 } else { 1304 } else {
881 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1305 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
882 } 1306 }
883 1307
884 cf::override; 1308 cf::override;
885 }, 1309 },
886); 1310);
887 1311
888sub load_extension {
889 my ($path) = @_;
890
891 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
892 my $base = $1;
893 my $pkg = $1;
894 $pkg =~ s/[^[:word:]]/_/g;
895 $pkg = "ext::$pkg";
896
897 warn "... loading '$path' into '$pkg'\n";
898
899 open my $fh, "<:utf8", $path
900 or die "$path: $!";
901
902 my $source =
903 "package $pkg; use strict; use utf8;\n"
904 . "#line 1 \"$path\"\n{\n"
905 . (do { local $/; <$fh> })
906 . "\n};\n1";
907
908 unless (eval $source) {
909 my $msg = $@ ? "$path: $@\n"
910 : "extension disabled.\n";
911 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
912 warn $@;
913 warn "mandatory extension failed to load, exiting.\n";
914 exit 1;
915 }
916 die $@;
917 }
918
919 push @EXTS, $pkg;
920}
921
922sub load_extensions { 1312sub load_extensions {
1313 cf::sync_job {
1314 my %todo;
1315
923 for my $ext (<$LIBDIR/*.ext>) { 1316 for my $path (<$LIBDIR/*.ext>) {
924 next unless -r $ext; 1317 next unless -r $path;
925 eval { 1318
926 load_extension $ext; 1319 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1320 my $base = $1;
1321 my $pkg = $1;
1322 $pkg =~ s/[^[:word:]]/_/g;
1323 $pkg = "ext::$pkg";
1324
1325 open my $fh, "<:utf8", $path
1326 or die "$path: $!";
1327
1328 my $source = do { local $/; <$fh> };
1329
1330 my %ext = (
1331 path => $path,
1332 base => $base,
1333 pkg => $pkg,
1334 );
1335
1336 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1337 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1338
1339 $ext{source} =
1340 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1341 . "#line 1 \"$path\"\n{\n"
1342 . $source
1343 . "\n};\n1";
1344
1345 $todo{$base} = \%ext;
1346 }
1347
1348 my %done;
1349 while (%todo) {
1350 my $progress;
1351
1352 while (my ($k, $v) = each %todo) {
1353 for (split /,\s*/, $v->{meta}{depends}) {
1354 goto skip
1355 unless exists $done{$_};
1356 }
1357
1358 warn "... loading '$k' into '$v->{pkg}'\n";
1359
1360 unless (eval $v->{source}) {
1361 my $msg = $@ ? "$v->{path}: $@\n"
1362 : "$v->{base}: extension inactive.\n";
1363
1364 if (exists $v->{meta}{mandatory}) {
1365 warn $msg;
1366 cf::cleanup "mandatory extension failed to load, exiting.";
1367 }
1368
1369 warn $msg;
1370 }
1371
1372 $done{$k} = delete $todo{$k};
1373 push @EXTS, $v->{pkg};
1374 $progress = 1;
927 1 1375 }
928 } or warn "$ext not loaded: $@"; 1376
1377 skip:
1378 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1379 unless $progress;
1380 }
929 } 1381 };
930} 1382}
931 1383
932############################################################################# 1384#############################################################################
933 1385
1386=back
1387
934=head2 CORE EXTENSIONS 1388=head2 CORE EXTENSIONS
935 1389
936Functions and methods that extend core crossfire objects. 1390Functions and methods that extend core crossfire objects.
937 1391
938=cut 1392=cut
… …
943 1397
944=head3 cf::player 1398=head3 cf::player
945 1399
946=over 4 1400=over 4
947 1401
1402=item cf::player::num_playing
1403
1404Returns the official number of playing players, as per the Crossfire metaserver rules.
1405
1406=cut
1407
1408sub num_playing {
1409 scalar grep
1410 $_->ob->map
1411 && !$_->hidden
1412 && !$_->ob->flag (cf::FLAG_WIZ),
1413 cf::player::list
1414}
1415
948=item cf::player::find $login 1416=item cf::player::find $login
949 1417
950Returns the given player object, loading it if necessary (might block). 1418Returns the given player object, loading it if necessary (might block).
951 1419
952=cut 1420=cut
953 1421
954sub playerdir($) { 1422sub playerdir($) {
955 cf::localdir 1423 "$PLAYERDIR/"
956 . "/"
957 . cf::playerdir
958 . "/"
959 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1424 . (ref $_[0] ? $_[0]->ob->name : $_[0])
960} 1425}
961 1426
962sub path($) { 1427sub path($) {
963 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1428 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
964 1429
965 (playerdir $login) . "/$login.pl" 1430 (playerdir $login) . "/playerdata"
966} 1431}
967 1432
968sub find_active($) { 1433sub find_active($) {
969 $cf::PLAYER{$_[0]} 1434 $cf::PLAYER{$_[0]}
970 and $cf::PLAYER{$_[0]}->active 1435 and $cf::PLAYER{$_[0]}->active
… …
983 my $login = $_[0]; 1448 my $login = $_[0];
984 1449
985 my $guard = cf::lock_acquire "user_find:$login"; 1450 my $guard = cf::lock_acquire "user_find:$login";
986 1451
987 $cf::PLAYER{$_[0]} || do { 1452 $cf::PLAYER{$_[0]} || do {
988 my $pl = load_pl path $login 1453 # rename old playerfiles to new ones
1454 #TODO: remove when no longer required
1455 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1456 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1457 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1458 aio_unlink +(playerdir $login) . "/$login.pl";
1459
1460 my $f = new_from_file cf::object::thawer path $login
989 or return; 1461 or return;
1462
1463 my $pl = cf::player::load_pl $f
1464 or return;
1465
1466 local $cf::PLAYER_LOADING{$login} = $pl;
1467 $f->resolve_delayed_derefs;
990 $cf::PLAYER{$login} = $pl 1468 $cf::PLAYER{$login} = $pl
991 } 1469 }
992 } 1470 }
993} 1471}
994 1472
… …
1003 return if $pl->{deny_save}; 1481 return if $pl->{deny_save};
1004 1482
1005 aio_mkdir playerdir $pl, 0770; 1483 aio_mkdir playerdir $pl, 0770;
1006 $pl->{last_save} = $cf::RUNTIME; 1484 $pl->{last_save} = $cf::RUNTIME;
1007 1485
1486 cf::get_slot 0.01;
1487
1008 $pl->save_pl ($path); 1488 $pl->save_pl ($path);
1009 Coro::cede; 1489 cf::cede_to_tick;
1010} 1490}
1011 1491
1012sub new($) { 1492sub new($) {
1013 my ($login) = @_; 1493 my ($login) = @_;
1014 1494
… …
1020 $cf::PLAYER{$login} = $self; 1500 $cf::PLAYER{$login} = $self;
1021 1501
1022 $self 1502 $self
1023} 1503}
1024 1504
1505=item $player->send_msg ($channel, $msg, $color, [extra...])
1506
1507=cut
1508
1509sub send_msg {
1510 my $ns = shift->ns
1511 or return;
1512 $ns->send_msg (@_);
1513}
1514
1025=item $pl->quit_character 1515=item $pl->quit_character
1026 1516
1027Nukes the player without looking back. If logged in, the connection will 1517Nukes the player without looking back. If logged in, the connection will
1028be destroyed. May block for a long time. 1518be destroyed. May block for a long time.
1029 1519
1030=cut 1520=cut
1031 1521
1032sub quit_character { 1522sub quit_character {
1033 my ($pl) = @_; 1523 my ($pl) = @_;
1034 1524
1525 my $name = $pl->ob->name;
1526
1035 $pl->{deny_save} = 1; 1527 $pl->{deny_save} = 1;
1036 $pl->password ("*"); # this should lock out the player until we nuked the dir 1528 $pl->password ("*"); # this should lock out the player until we nuked the dir
1037 1529
1038 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1530 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1039 $pl->deactivate; 1531 $pl->deactivate;
1532 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1533 $pl->ob->check_score;
1040 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1534 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1041 $pl->ns->destroy if $pl->ns; 1535 $pl->ns->destroy if $pl->ns;
1042 1536
1043 my $path = playerdir $pl; 1537 my $path = playerdir $pl;
1044 my $temp = "$path~$cf::RUNTIME~deleting~"; 1538 my $temp = "$path~$cf::RUNTIME~deleting~";
1045 aio_rename $path, $temp; 1539 aio_rename $path, $temp;
1046 delete $cf::PLAYER{$pl->ob->name}; 1540 delete $cf::PLAYER{$pl->ob->name};
1047 $pl->destroy; 1541 $pl->destroy;
1542
1543 my $prefix = qr<^~\Q$name\E/>;
1544
1545 # nuke player maps
1546 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1547
1048 IO::AIO::aio_rmtree $temp; 1548 IO::AIO::aio_rmtree $temp;
1549}
1550
1551=item $pl->kick
1552
1553Kicks a player out of the game. This destroys the connection.
1554
1555=cut
1556
1557sub kick {
1558 my ($pl, $kicker) = @_;
1559
1560 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1561 $pl->killer ("kicked");
1562 $pl->ns->destroy;
1049} 1563}
1050 1564
1051=item cf::player::list_logins 1565=item cf::player::list_logins
1052 1566
1053Returns am arrayref of all valid playernames in the system, can take a 1567Returns am arrayref of all valid playernames in the system, can take a
1054while and may block, so not sync_job-capable, ever. 1568while and may block, so not sync_job-capable, ever.
1055 1569
1056=cut 1570=cut
1057 1571
1058sub list_logins { 1572sub list_logins {
1059 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1573 my $dirs = aio_readdir $PLAYERDIR
1060 or return []; 1574 or return [];
1061 1575
1062 my @logins; 1576 my @logins;
1063 1577
1064 for my $login (@$dirs) { 1578 for my $login (@$dirs) {
1579 my $path = path $login;
1580
1581 # a .pst is a dead give-away for a valid player
1582 # if no pst file found, open and chekc for blocked users
1583 if (aio_stat "$path.pst") {
1065 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1584 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1066 aio_read $fh, 0, 512, my $buf, 0 or next; 1585 aio_read $fh, 0, 512, my $buf, 0 or next;
1067 $buf !~ /^password -------------$/m or next; # official not-valid tag 1586 $buf !~ /^password -------------$/m or next; # official not-valid tag
1587 }
1068 1588
1069 utf8::decode $login; 1589 utf8::decode $login;
1070 push @logins, $login; 1590 push @logins, $login;
1071 } 1591 }
1072 1592
… …
1099 } 1619 }
1100 1620
1101 \@paths 1621 \@paths
1102} 1622}
1103 1623
1624=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1625
1626Expand crossfire pod fragments into protocol xml.
1627
1628=cut
1629
1630sub expand_cfpod {
1631 my ($self, $pod) = @_;
1632
1633 my @nest = [qr<\G$>, undef, ""];
1634 my $xml;
1635
1636 for ($pod) {
1637 while () {
1638 if (/\G( (?: [^BCEGHITUZ&>\n\ ]+ | [BCEGHITUZ](?!<) | \ (?!>) )+ )/xgcs) {
1639 $xml .= $1;
1640 } elsif (/\G\n(?=\S)/xgcs) {
1641 $xml .= " ";
1642 } elsif (/\G\n/xgcs) {
1643 $xml .= "\n";
1644 } elsif (/\G ([BCEGHITUZ]) (< (?: <+\ | (?!<) ) )/xgcs) {
1645 my ($code, $delim) = ($1, scalar reverse $2);
1646 $delim =~ y/</>/; # delim now contains the stop sequence
1647 $delim = qr{\G\Q$delim};
1648
1649 my $cb;
1650
1651 if ($code eq "B") {
1652 $cb = sub { "<b>$_[0]</b>" };
1653 } elsif ($code eq "C") {
1654 $cb = sub { "<tt>$_[0]</tt>" };
1655 } elsif ($code eq "E") {
1656 $cb = sub { warn "E<$_[0]>\n";"&$_[0];" };
1657 } elsif ($code eq "G") {
1658 $cb = sub {
1659 my ($male, $female) = split /\|/, $_[0];
1660 $self->gender ? $female : $male
1661 };
1662 } elsif ($code eq "H") {
1663 $cb = sub {
1664 (
1665 "<fg name=\"lightblue\">[$_[0] (Use hintmode to suppress hints)]</fg>",
1666 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1667 "",
1668 )[$self->{hintmode}];
1669 };
1670 } elsif ($code eq "I") {
1671 $cb = sub { "<i>$_[0]</i>" };
1672 } elsif ($code eq "T") {
1673 $cb = sub { "<big><b>$_[0]</b></big>" };
1674 } elsif ($code eq "U") {
1675 $cb = sub { "<u>$_[0]</u>" };
1676 } elsif ($code eq "Z") {
1677 $cb = sub { };
1678 } else {
1679 die "FATAL error in expand_cfpod";
1680 }
1681
1682 push @nest, [$delim, $cb, $xml];
1683 undef $xml;
1684
1685 } elsif ($_ =~ /$nest[-1][0]/gcs) {
1686 my $nest = pop @nest;
1687
1688 if ($nest->[1]) {
1689 $xml = $nest->[2] . $nest->[1]->($xml);
1690 } else {
1691 last;
1692 }
1693 } elsif (/\G</xgcs) {
1694 $xml .= "&lt;";
1695 } elsif (/\G&/xgcs) {
1696 $xml .= "&amp;";
1697 } elsif (/\G>/xgcs) {
1698 $xml .= ">";
1699 } else {
1700 if ($pod =~ /\G(.+)/xgcs) {
1701 warn "parse error (at $1)($nest[-1][0]) while expanding cfpod:\n$pod";
1702 last;
1703 } else {
1704 warn "parse error (unclosed interior sequence at end of cfpod) while expanding cfpod:\n$pod";
1705 return "<b>Sorry, the server encountered an internal error when formatting this message, please report this.</b>";
1706 }
1707 }
1708 }
1709 }
1710
1711 $xml
1712}
1713
1714sub hintmode {
1715 $_[0]{hintmode} = $_[1] if @_ > 1;
1716 $_[0]{hintmode}
1717}
1718
1104=item $player->ext_reply ($msgid, $msgtype, %msg) 1719=item $player->ext_reply ($msgid, @msg)
1105 1720
1106Sends an ext reply to the player. 1721Sends an ext reply to the player.
1107 1722
1108=cut 1723=cut
1109 1724
1110sub ext_reply($$$%) { 1725sub ext_reply($$@) {
1111 my ($self, $id, %msg) = @_; 1726 my ($self, $id, @msg) = @_;
1112 1727
1113 $msg{msgid} = $id; 1728 $self->ns->ext_reply ($id, @msg)
1114
1115 $self->send ("ext " . cf::to_json \%msg);
1116} 1729}
1117 1730
1118package cf; 1731=item $player->ext_msg ($type, @msg)
1732
1733Sends an ext event to the client.
1734
1735=cut
1736
1737sub ext_msg($$@) {
1738 my ($self, $type, @msg) = @_;
1739
1740 $self->ns->ext_msg ($type, @msg);
1741}
1742
1743=head3 cf::region
1744
1745=over 4
1746
1747=cut
1748
1749package cf::region;
1750
1751=item cf::region::find_by_path $path
1752
1753Tries to decuce the likely region for a map knowing only its path.
1754
1755=cut
1756
1757sub find_by_path($) {
1758 my ($path) = @_;
1759
1760 my ($match, $specificity);
1761
1762 for my $region (list) {
1763 if ($region->{match} && $path =~ $region->{match}) {
1764 ($match, $specificity) = ($region, $region->specificity)
1765 if $region->specificity > $specificity;
1766 }
1767 }
1768
1769 $match
1770}
1119 1771
1120=back 1772=back
1121
1122 1773
1123=head3 cf::map 1774=head3 cf::map
1124 1775
1125=over 4 1776=over 4
1126 1777
… …
1138our $MAX_RESET = 3600; 1789our $MAX_RESET = 3600;
1139our $DEFAULT_RESET = 3000; 1790our $DEFAULT_RESET = 3000;
1140 1791
1141sub generate_random_map { 1792sub generate_random_map {
1142 my ($self, $rmp) = @_; 1793 my ($self, $rmp) = @_;
1794
1795 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1796
1143 # mit "rum" bekleckern, nicht 1797 # mit "rum" bekleckern, nicht
1144 $self->_create_random_map ( 1798 $self->_create_random_map (
1145 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1799 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1146 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1800 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1147 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1801 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1181 my ($self, $merge) = @_; 1835 my ($self, $merge) = @_;
1182 1836
1183 # we have to keep some variables in memory intact 1837 # we have to keep some variables in memory intact
1184 local $self->{path}; 1838 local $self->{path};
1185 local $self->{load_path}; 1839 local $self->{load_path};
1186 local $self->{deny_save};
1187 local $self->{deny_reset};
1188 1840
1189 $self->SUPER::thawer_merge ($merge); 1841 $self->SUPER::thawer_merge ($merge);
1190} 1842}
1191 1843
1192sub normalise { 1844sub normalise {
… …
1239 $self->init; # pass $1 etc. 1891 $self->init; # pass $1 etc.
1240 return $self; 1892 return $self;
1241 } 1893 }
1242 } 1894 }
1243 1895
1244 Carp::carp "unable to resolve path '$path' (base '$base')."; 1896 Carp::cluck "unable to resolve path '$path' (base '$base').";
1245 () 1897 ()
1246} 1898}
1247 1899
1248sub init { 1900sub init {
1249 my ($self) = @_; 1901 my ($self) = @_;
… …
1264 1916
1265# the original (read-only) location 1917# the original (read-only) location
1266sub load_path { 1918sub load_path {
1267 my ($self) = @_; 1919 my ($self) = @_;
1268 1920
1269 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path} 1921 "$MAPDIR/$self->{path}.map"
1270} 1922}
1271 1923
1272# the temporary/swap location 1924# the temporary/swap location
1273sub save_path { 1925sub save_path {
1274 my ($self) = @_; 1926 my ($self) = @_;
1275 1927
1276 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1928 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1277 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path 1929 "$TMPDIR/$path.map"
1278} 1930}
1279 1931
1280# the unique path, undef == no special unique path 1932# the unique path, undef == no special unique path
1281sub uniq_path { 1933sub uniq_path {
1282 my ($self) = @_; 1934 my ($self) = @_;
1283 1935
1284 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1936 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1285 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1937 "$UNIQUEDIR/$path"
1286} 1938}
1287 1939
1288# and all this just because we cannot iterate over 1940# and all this just because we cannot iterate over
1289# all maps in C++... 1941# all maps in C++...
1290sub change_all_map_light { 1942sub change_all_map_light {
… …
1292 1944
1293 $_->change_map_light ($change) 1945 $_->change_map_light ($change)
1294 for grep $_->outdoor, values %cf::MAP; 1946 for grep $_->outdoor, values %cf::MAP;
1295} 1947}
1296 1948
1949sub decay_objects {
1950 my ($self) = @_;
1951
1952 return if $self->{deny_reset};
1953
1954 $self->do_decay_objects;
1955}
1956
1297sub unlink_save { 1957sub unlink_save {
1298 my ($self) = @_; 1958 my ($self) = @_;
1299 1959
1300 utf8::encode (my $save = $self->save_path); 1960 utf8::encode (my $save = $self->save_path);
1301 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1961 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
… …
1304 1964
1305sub load_header_from($) { 1965sub load_header_from($) {
1306 my ($self, $path) = @_; 1966 my ($self, $path) = @_;
1307 1967
1308 utf8::encode $path; 1968 utf8::encode $path;
1309 #aio_open $path, O_RDONLY, 0 1969 my $f = new_from_file cf::object::thawer $path
1310 # or return;
1311
1312 $self->_load_header ($path)
1313 or return; 1970 or return;
1971
1972 $self->_load_header ($f)
1973 or return;
1974
1975 local $MAP_LOADING{$self->{path}} = $self;
1976 $f->resolve_delayed_derefs;
1314 1977
1315 $self->{load_path} = $path; 1978 $self->{load_path} = $path;
1316 1979
1317 1 1980 1
1318} 1981}
… …
1357 $self->load_header_orig 2020 $self->load_header_orig
1358 or return; 2021 or return;
1359 $self->prepare_orig; 2022 $self->prepare_orig;
1360 } 2023 }
1361 2024
2025 $self->{deny_reset} = 1
2026 if $self->no_reset;
2027
2028 $self->default_region (cf::region::find_by_path $self->{path})
2029 unless $self->default_region;
2030
1362 1 2031 1
1363} 2032}
1364 2033
1365sub find; 2034sub find;
1366sub find { 2035sub find {
1367 my ($path, $origin) = @_; 2036 my ($path, $origin) = @_;
1368 2037
1369 $path = normalise $path, $origin && $origin->path; 2038 $path = normalise $path, $origin && $origin->path;
1370 2039
2040 cf::lock_wait "map_data:$path";#d#remove
1371 cf::lock_wait "map_find:$path"; 2041 cf::lock_wait "map_find:$path";
1372 2042
1373 $cf::MAP{$path} || do { 2043 $cf::MAP{$path} || do {
2044 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1374 my $guard = cf::lock_acquire "map_find:$path"; 2045 my $guard2 = cf::lock_acquire "map_find:$path";
2046
1375 my $map = new_from_path cf::map $path 2047 my $map = new_from_path cf::map $path
1376 or return; 2048 or return;
1377 2049
1378 $map->{last_save} = $cf::RUNTIME; 2050 $map->{last_save} = $cf::RUNTIME;
1379 2051
1380 $map->load_header 2052 $map->load_header
1381 or return; 2053 or return;
1382 2054
1383 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 2055 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1384 # doing this can freeze the server in a sync job, obviously 2056 # doing this can freeze the server in a sync job, obviously
1385 #$cf::WAIT_FOR_TICK->wait; 2057 #$cf::WAIT_FOR_TICK->wait;
2058 undef $guard2;
2059 undef $guard1;
1386 $map->reset; 2060 $map->reset;
1387 undef $guard;
1388 return find $path; 2061 return find $path;
1389 } 2062 }
1390 2063
1391 $cf::MAP{$path} = $map 2064 $cf::MAP{$path} = $map
1392 } 2065 }
… …
1399 my ($self) = @_; 2072 my ($self) = @_;
1400 2073
1401 local $self->{deny_reset} = 1; # loading can take a long time 2074 local $self->{deny_reset} = 1; # loading can take a long time
1402 2075
1403 my $path = $self->{path}; 2076 my $path = $self->{path};
2077
2078 {
1404 my $guard = cf::lock_acquire "map_load:$path"; 2079 my $guard = cf::lock_acquire "map_data:$path";
1405 2080
2081 return unless $self->valid;
1406 return if $self->in_memory != cf::MAP_SWAPPED; 2082 return unless $self->in_memory == cf::MAP_SWAPPED;
1407 2083
1408 $self->in_memory (cf::MAP_LOADING); 2084 $self->in_memory (cf::MAP_LOADING);
1409 2085
1410 $self->alloc; 2086 $self->alloc;
1411 2087
1412 $self->pre_load; 2088 $self->pre_load;
2089 cf::cede_to_tick;
1413 2090
1414 $self->_load_objects ($self->{load_path}, 1) 2091 my $f = new_from_file cf::object::thawer $self->{load_path};
2092 $f->skip_block;
2093 $self->_load_objects ($f)
1415 or return; 2094 or return;
1416 2095
1417 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2096 $self->post_load_original
1418 if delete $self->{load_original}; 2097 if delete $self->{load_original};
1419 2098
1420 if (my $uniq = $self->uniq_path) { 2099 if (my $uniq = $self->uniq_path) {
1421 utf8::encode $uniq; 2100 utf8::encode $uniq;
1422 if (aio_open $uniq, O_RDONLY, 0) { 2101 unless (aio_stat $uniq) {
2102 if (my $f = new_from_file cf::object::thawer $uniq) {
1423 $self->clear_unique_items; 2103 $self->clear_unique_items;
1424 $self->_load_objects ($uniq, 0); 2104 $self->_load_objects ($f);
2105 $f->resolve_delayed_derefs;
2106 }
1425 } 2107 }
1426 } 2108 }
1427 2109
1428 Coro::cede; 2110 $f->resolve_delayed_derefs;
1429 2111
2112 cf::cede_to_tick;
1430 # now do the right thing for maps 2113 # now do the right thing for maps
1431 $self->link_multipart_objects; 2114 $self->link_multipart_objects;
1432
1433 unless ($self->{deny_activate}) {
1434 $self->decay_objects;
1435 $self->fix_auto_apply;
1436 $self->update_buttons;
1437 Coro::cede;
1438 $self->set_darkness_map;
1439 $self->difficulty ($self->estimate_difficulty) 2115 $self->difficulty ($self->estimate_difficulty)
1440 unless $self->difficulty; 2116 unless $self->difficulty;
1441 Coro::cede; 2117 cf::cede_to_tick;
2118
2119 unless ($self->{deny_activate}) {
2120 $self->decay_objects;
2121 $self->fix_auto_apply;
2122 $self->update_buttons;
2123 cf::cede_to_tick;
2124 $self->set_darkness_map;
2125 cf::cede_to_tick;
1442 $self->activate; 2126 $self->activate;
2127 }
2128
2129 $self->{last_save} = $cf::RUNTIME;
2130 $self->last_access ($cf::RUNTIME);
2131
2132 $self->in_memory (cf::MAP_ACTIVE);
1443 } 2133 }
1444 2134
1445 $self->post_load; 2135 $self->post_load;
1446
1447 $self->in_memory (cf::MAP_IN_MEMORY);
1448} 2136}
1449 2137
1450sub customise_for { 2138sub customise_for {
1451 my ($self, $ob) = @_; 2139 my ($self, $ob) = @_;
1452 2140
1453 return find "~" . $ob->name . "/" . $self->{path} 2141 return find "~" . $ob->name . "/" . $self->{path}
1454 if $self->per_player; 2142 if $self->per_player;
1455 2143
2144# return find "?party/" . $ob->name . "/" . $self->{path}
2145# if $self->per_party;
2146
1456 $self 2147 $self
1457} 2148}
1458 2149
1459# find and load all maps in the 3x3 area around a map 2150# find and load all maps in the 3x3 area around a map
1460sub load_diag { 2151sub load_neighbours {
1461 my ($map) = @_; 2152 my ($map) = @_;
1462 2153
1463 my @diag; # diagonal neighbours 2154 my @neigh; # diagonal neighbours
1464 2155
1465 for (0 .. 3) { 2156 for (0 .. 3) {
1466 my $neigh = $map->tile_path ($_) 2157 my $neigh = $map->tile_path ($_)
1467 or next; 2158 or next;
1468 $neigh = find $neigh, $map 2159 $neigh = find $neigh, $map
1469 or next; 2160 or next;
1470 $neigh->load; 2161 $neigh->load;
1471 2162
2163 push @neigh,
1472 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2164 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1473 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2165 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1474 } 2166 }
1475 2167
1476 for (@diag) { 2168 for (grep defined $_->[0], @neigh) {
2169 my ($path, $origin) = @$_;
1477 my $neigh = find @$_ 2170 my $neigh = find $path, $origin
1478 or next; 2171 or next;
1479 $neigh->load; 2172 $neigh->load;
1480 } 2173 }
1481} 2174}
1482 2175
… …
1487} 2180}
1488 2181
1489sub do_load_sync { 2182sub do_load_sync {
1490 my ($map) = @_; 2183 my ($map) = @_;
1491 2184
2185 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2186 if $Coro::current == $Coro::main;
2187
1492 cf::sync_job { $map->load }; 2188 cf::sync_job { $map->load };
1493} 2189}
1494 2190
1495our %MAP_PREFETCH; 2191our %MAP_PREFETCH;
1496our $MAP_PREFETCHER = undef; 2192our $MAP_PREFETCHER = undef;
1497 2193
1498sub find_async { 2194sub find_async {
1499 my ($path, $origin) = @_; 2195 my ($path, $origin, $load) = @_;
1500 2196
1501 $path = normalise $path, $origin && $origin->{path}; 2197 $path = normalise $path, $origin && $origin->{path};
1502 2198
1503 if (my $map = $cf::MAP{$path}) { 2199 if (my $map = $cf::MAP{$path}) {
1504 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2200 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
1505 } 2201 }
1506 2202
1507 undef $MAP_PREFETCH{$path}; 2203 $MAP_PREFETCH{$path} |= $load;
2204
1508 $MAP_PREFETCHER ||= cf::async { 2205 $MAP_PREFETCHER ||= cf::async {
2206 $Coro::current->{desc} = "map prefetcher";
2207
1509 while (%MAP_PREFETCH) { 2208 while (%MAP_PREFETCH) {
1510 for my $path (keys %MAP_PREFETCH) { 2209 while (my ($k, $v) = each %MAP_PREFETCH) {
1511 my $map = find $path 2210 if (my $map = find $k) {
1512 or next;
1513 $map->load; 2211 $map->load if $v;
2212 }
1514 2213
1515 delete $MAP_PREFETCH{$path}; 2214 delete $MAP_PREFETCH{$k};
1516 } 2215 }
1517 } 2216 }
1518 undef $MAP_PREFETCHER; 2217 undef $MAP_PREFETCHER;
1519 }; 2218 };
1520 $MAP_PREFETCHER->prio (6); 2219 $MAP_PREFETCHER->prio (6);
… …
1523} 2222}
1524 2223
1525sub save { 2224sub save {
1526 my ($self) = @_; 2225 my ($self) = @_;
1527 2226
1528 my $lock = cf::lock_acquire "map_data:" . $self->path; 2227 my $lock = cf::lock_acquire "map_data:$self->{path}";
1529 2228
1530 $self->{last_save} = $cf::RUNTIME; 2229 $self->{last_save} = $cf::RUNTIME;
1531 2230
1532 return unless $self->dirty; 2231 return unless $self->dirty;
1533 2232
… …
1539 return if $self->{deny_save}; 2238 return if $self->{deny_save};
1540 2239
1541 local $self->{last_access} = $self->last_access;#d# 2240 local $self->{last_access} = $self->last_access;#d#
1542 2241
1543 cf::async { 2242 cf::async {
2243 $Coro::current->{desc} = "map player save";
1544 $_->contr->save for $self->players; 2244 $_->contr->save for $self->players;
1545 }; 2245 };
2246
2247 cf::get_slot 0.02;
1546 2248
1547 if ($uniq) { 2249 if ($uniq) {
1548 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2250 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1549 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2251 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1550 } else { 2252 } else {
… …
1556 my ($self) = @_; 2258 my ($self) = @_;
1557 2259
1558 # save first because save cedes 2260 # save first because save cedes
1559 $self->save; 2261 $self->save;
1560 2262
1561 my $lock = cf::lock_acquire "map_data:" . $self->path; 2263 my $lock = cf::lock_acquire "map_data:$self->{path}";
1562 2264
1563 return if $self->players; 2265 return if $self->players;
1564 return if $self->in_memory != cf::MAP_IN_MEMORY; 2266 return if $self->in_memory != cf::MAP_ACTIVE;
1565 return if $self->{deny_save}; 2267 return if $self->{deny_save};
1566 2268
2269 $self->in_memory (cf::MAP_SWAPPED);
2270
2271 $self->deactivate;
2272 $_->clear_links_to ($self) for values %cf::MAP;
1567 $self->clear; 2273 $self->clear;
1568 $self->in_memory (cf::MAP_SWAPPED);
1569} 2274}
1570 2275
1571sub reset_at { 2276sub reset_at {
1572 my ($self) = @_; 2277 my ($self) = @_;
1573 2278
1574 # TODO: safety, remove and allow resettable per-player maps 2279 # TODO: safety, remove and allow resettable per-player maps
1575 return 1e99 if $self->isa ("ext::map_per_player");#d#
1576 return 1e99 if $self->{deny_reset}; 2280 return 1e99 if $self->{deny_reset};
1577 2281
1578 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2282 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1579 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2283 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1580 2284
… …
1591 my ($self) = @_; 2295 my ($self) = @_;
1592 2296
1593 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2297 my $lock = cf::lock_acquire "map_data:$self->{path}";
1594 2298
1595 return if $self->players; 2299 return if $self->players;
1596 return if $self->isa ("ext::map_per_player");#d#
1597 2300
1598 warn "resetting map ", $self->path;#d# 2301 warn "resetting map ", $self->path;
1599 2302
1600 $self->in_memory (cf::MAP_SWAPPED); 2303 $self->in_memory (cf::MAP_SWAPPED);
1601 2304
1602 # need to save uniques path 2305 # need to save uniques path
1603 unless ($self->{deny_save}) { 2306 unless ($self->{deny_save}) {
… …
1607 if $uniq; 2310 if $uniq;
1608 } 2311 }
1609 2312
1610 delete $cf::MAP{$self->path}; 2313 delete $cf::MAP{$self->path};
1611 2314
2315 $self->deactivate;
2316 $_->clear_links_to ($self) for values %cf::MAP;
1612 $self->clear; 2317 $self->clear;
1613
1614 $_->clear_links_to ($self) for values %cf::MAP;
1615 2318
1616 $self->unlink_save; 2319 $self->unlink_save;
1617 $self->destroy; 2320 $self->destroy;
1618} 2321}
1619 2322
1620my $nuke_counter = "aaaa"; 2323my $nuke_counter = "aaaa";
1621 2324
1622sub nuke { 2325sub nuke {
1623 my ($self) = @_; 2326 my ($self) = @_;
1624 2327
2328 {
2329 my $lock = cf::lock_acquire "map_data:$self->{path}";
2330
1625 delete $cf::MAP{$self->path}; 2331 delete $cf::MAP{$self->path};
1626 2332
1627 $self->unlink_save; 2333 $self->unlink_save;
1628 2334
1629 bless $self, "cf::map"; 2335 bless $self, "cf::map";
1630 delete $self->{deny_reset}; 2336 delete $self->{deny_reset};
1631 $self->{deny_save} = 1; 2337 $self->{deny_save} = 1;
1632 $self->reset_timeout (1); 2338 $self->reset_timeout (1);
1633 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2339 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1634 2340
1635 $cf::MAP{$self->path} = $self; 2341 $cf::MAP{$self->path} = $self;
2342 }
1636 2343
1637 $self->reset; # polite request, might not happen 2344 $self->reset; # polite request, might not happen
2345}
2346
2347=item $maps = cf::map::tmp_maps
2348
2349Returns an arrayref with all map paths of currently instantiated and saved
2350maps. May block.
2351
2352=cut
2353
2354sub tmp_maps() {
2355 [
2356 map {
2357 utf8::decode $_;
2358 /\.map$/
2359 ? normalise $_
2360 : ()
2361 } @{ aio_readdir $TMPDIR or [] }
2362 ]
2363}
2364
2365=item $maps = cf::map::random_maps
2366
2367Returns an arrayref with all map paths of currently instantiated and saved
2368random maps. May block.
2369
2370=cut
2371
2372sub random_maps() {
2373 [
2374 map {
2375 utf8::decode $_;
2376 /\.map$/
2377 ? normalise "?random/$_"
2378 : ()
2379 } @{ aio_readdir $RANDOMDIR or [] }
2380 ]
1638} 2381}
1639 2382
1640=item cf::map::unique_maps 2383=item cf::map::unique_maps
1641 2384
1642Returns an arrayref of paths of all shared maps that have 2385Returns an arrayref of paths of all shared maps that have
1643instantiated unique items. May block. 2386instantiated unique items. May block.
1644 2387
1645=cut 2388=cut
1646 2389
1647sub unique_maps() { 2390sub unique_maps() {
1648 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2391 [
1649 or return; 2392 map {
1650
1651 my @paths;
1652
1653 for (@$files) {
1654 utf8::decode $_; 2393 utf8::decode $_;
1655 next if /\.pst$/; 2394 s/\.map$//; # TODO future compatibility hack
1656 next unless /^$PATH_SEP/o; 2395 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
1657 2396 ? ()
1658 push @paths, cf::map::normalise $_; 2397 : normalise $_
2398 } @{ aio_readdir $UNIQUEDIR or [] }
1659 } 2399 ]
1660
1661 \@paths
1662} 2400}
1663
1664package cf;
1665 2401
1666=back 2402=back
1667 2403
1668=head3 cf::object 2404=head3 cf::object
1669 2405
… …
1673 2409
1674=over 4 2410=over 4
1675 2411
1676=item $ob->inv_recursive 2412=item $ob->inv_recursive
1677 2413
1678Returns the inventory of the object _and_ their inventories, recursively. 2414Returns the inventory of the object I<and> their inventories, recursively,
2415but I<not> the object itself.
1679 2416
1680=cut 2417=cut
1681 2418
1682sub inv_recursive_; 2419sub inv_recursive_;
1683sub inv_recursive_ { 2420sub inv_recursive_ {
… …
1686 2423
1687sub inv_recursive { 2424sub inv_recursive {
1688 inv_recursive_ inv $_[0] 2425 inv_recursive_ inv $_[0]
1689} 2426}
1690 2427
2428=item $ref = $ob->ref
2429
2430Creates and returns a persistent reference to an object that can be stored as a string.
2431
2432=item $ob = cf::object::deref ($refstring)
2433
2434returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2435even if the object actually exists. May block.
2436
2437=cut
2438
2439sub deref {
2440 my ($ref) = @_;
2441
2442 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2443 my ($uuid, $name) = ($1, $2);
2444 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2445 or return;
2446 $pl->ob->uuid eq $uuid
2447 or return;
2448
2449 $pl->ob
2450 } else {
2451 warn "$ref: cannot resolve object reference\n";
2452 undef
2453 }
2454}
2455
1691package cf; 2456package cf;
1692 2457
1693=back 2458=back
1694 2459
1695=head3 cf::object::player 2460=head3 cf::object::player
… …
1701Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2466Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
1702can be C<undef>. Does the right thing when the player is currently in a 2467can be C<undef>. Does the right thing when the player is currently in a
1703dialogue with the given NPC character. 2468dialogue with the given NPC character.
1704 2469
1705=cut 2470=cut
2471
2472our $SAY_CHANNEL = {
2473 id => "say",
2474 title => "Map",
2475 reply => "say ",
2476 tooltip => "Things said to and replied from npcs near you and other players on the same map only.",
2477};
2478
2479our $CHAT_CHANNEL = {
2480 id => "chat",
2481 title => "Chat",
2482 reply => "chat ",
2483 tooltip => "Player chat and shouts, global to the server.",
2484};
1706 2485
1707# rough implementation of a future "reply" method that works 2486# rough implementation of a future "reply" method that works
1708# with dialog boxes. 2487# with dialog boxes.
1709#TODO: the first argument must go, split into a $npc->reply_to ( method 2488#TODO: the first argument must go, split into a $npc->reply_to ( method
1710sub cf::object::player::reply($$$;$) { 2489sub cf::object::player::reply($$$;$) {
… …
1712 2491
1713 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2492 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1714 2493
1715 if ($self->{record_replies}) { 2494 if ($self->{record_replies}) {
1716 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2495 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2496
1717 } else { 2497 } else {
2498 my $pl = $self->contr;
2499
2500 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2501 my $dialog = $pl->{npc_dialog};
2502 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2503
2504 } else {
1718 $msg = $npc->name . " says: $msg" if $npc; 2505 $msg = $npc->name . " says: $msg" if $npc;
1719 $self->message ($msg, $flags); 2506 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2507 }
1720 } 2508 }
2509}
2510
2511=item $object->send_msg ($channel, $msg, $color, [extra...])
2512
2513=cut
2514
2515sub cf::object::send_msg {
2516 my $pl = shift->contr
2517 or return;
2518 $pl->send_msg (@_);
1721} 2519}
1722 2520
1723=item $player_object->may ("access") 2521=item $player_object->may ("access")
1724 2522
1725Returns wether the given player is authorized to access resource "access" 2523Returns wether the given player is authorized to access resource "access"
… …
1772 $self->deactivate_recursive; 2570 $self->deactivate_recursive;
1773 2571
1774 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2572 return if UNIVERSAL::isa $self->map, "ext::map_link";
1775 2573
1776 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2574 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1777 if $self->map; 2575 if $self->map && $self->map->{path} ne "{link}";
1778 2576
1779 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2577 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1780} 2578}
1781 2579
1782sub cf::object::player::leave_link { 2580sub cf::object::player::leave_link {
1783 my ($self, $map, $x, $y) = @_; 2581 my ($self, $map, $x, $y) = @_;
2582
2583 return unless $self->contr->active;
1784 2584
1785 my $link_pos = delete $self->{_link_pos}; 2585 my $link_pos = delete $self->{_link_pos};
1786 2586
1787 unless ($map) { 2587 unless ($map) {
1788 # restore original map position 2588 # restore original map position
… …
1802 # use -1 or undef as default coordinates, not 0, 0 2602 # use -1 or undef as default coordinates, not 0, 0
1803 ($x, $y) = ($map->enter_x, $map->enter_y) 2603 ($x, $y) = ($map->enter_x, $map->enter_y)
1804 if $x <=0 && $y <= 0; 2604 if $x <=0 && $y <= 0;
1805 2605
1806 $map->load; 2606 $map->load;
1807 $map->load_diag; 2607 $map->load_neighbours;
1808 2608
1809 return unless $self->contr->active; 2609 return unless $self->contr->active;
1810 $self->activate_recursive; 2610 $self->activate_recursive;
1811 2611
1812 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2612 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1813 $self->enter_map ($map, $x, $y); 2613 $self->enter_map ($map, $x, $y);
1814} 2614}
1815 2615
1816cf::player->attach ( 2616=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1817 on_logout => sub {
1818 my ($pl) = @_;
1819 2617
1820 # abort map switching before logout 2618Moves the player to the given map-path and coordinates by first freezing
1821 if ($pl->ob->{_link_pos}) { 2619her, loading and preparing them map, calling the provided $check callback
1822 cf::sync_job { 2620that has to return the map if sucecssful, and then unfreezes the player on
1823 $pl->ob->leave_link 2621the new (success) or old (failed) map position. In either case, $done will
1824 }; 2622be called at the end of this process.
1825 }
1826 },
1827 on_login => sub {
1828 my ($pl) = @_;
1829 2623
1830 # try to abort aborted map switching on player login :) 2624Note that $check will be called with a potentially non-loaded map, so if
1831 # should happen only on crashes 2625it needs a loaded map it has to call C<< ->load >>.
1832 if ($pl->ob->{_link_pos}) {
1833 $pl->ob->enter_link;
1834 (async {
1835 $pl->ob->reply (undef,
1836 "There was an internal problem at your last logout, "
1837 . "the server will try to bring you to your intended destination in a second.",
1838 cf::NDI_RED);
1839 # we need this sleep as the login has a concurrent enter_exit running
1840 # and this sleep increases chances of the player not ending up in scorn
1841 Coro::Timer::sleep 1;
1842 $pl->ob->leave_link;
1843 })->prio (2);
1844 }
1845 },
1846);
1847 2626
1848=item $player_object->goto ($path, $x, $y)
1849
1850=cut 2627=cut
2628
2629our $GOTOGEN;
1851 2630
1852sub cf::object::player::goto { 2631sub cf::object::player::goto {
1853 my ($self, $path, $x, $y) = @_; 2632 my ($self, $path, $x, $y, $check, $done) = @_;
2633
2634 # do generation counting so two concurrent goto's will be executed in-order
2635 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1854 2636
1855 $self->enter_link; 2637 $self->enter_link;
1856 2638
1857 (async { 2639 (async {
2640 $Coro::current->{desc} = "player::goto $path $x $y";
2641
2642 # *tag paths override both path and x|y
2643 if ($path =~ /^\*(.*)$/) {
2644 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2645 my $ob = $obs[rand @obs];
2646
2647 # see if we actually can go there
2648 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2649 $ob = $obs[rand @obs];
2650 } else {
2651 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2652 }
2653 # else put us there anyways for now #d#
2654
2655 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2656 } else {
2657 ($path, $x, $y) = (undef, undef, undef);
2658 }
2659 }
2660
1858 my $map = eval { 2661 my $map = eval {
1859 my $map = cf::map::find $path; 2662 my $map = defined $path ? cf::map::find $path : undef;
2663
2664 if ($map) {
1860 $map = $map->customise_for ($self) if $map; 2665 $map = $map->customise_for ($self);
2666 $map = $check->($map) if $check && $map;
2667 } else {
2668 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2669 }
2670
1861 $map 2671 $map
2672 };
2673
2674 if ($@) {
2675 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2676 LOG llevError | logBacktrace, Carp::longmess $@;
1862 } or 2677 }
1863 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1864 2678
2679 if ($gen == $self->{_goto_generation}) {
2680 delete $self->{_goto_generation};
1865 $self->leave_link ($map, $x, $y); 2681 $self->leave_link ($map, $x, $y);
2682 }
2683
2684 $done->() if $done;
1866 })->prio (1); 2685 })->prio (1);
1867} 2686}
1868 2687
1869=item $player_object->enter_exit ($exit_object) 2688=item $player_object->enter_exit ($exit_object)
1870 2689
… …
1890} 2709}
1891 2710
1892sub prepare_random_map { 2711sub prepare_random_map {
1893 my ($exit) = @_; 2712 my ($exit) = @_;
1894 2713
1895 my $guard = cf::lock_acquire "exit_prepare:$exit";
1896
1897 # all this does is basically replace the /! path by 2714 # all this does is basically replace the /! path by
1898 # a new random map path (?random/...) with a seed 2715 # a new random map path (?random/...) with a seed
1899 # that depends on the exit object 2716 # that depends on the exit object
1900 2717
1901 my $rmp = parse_random_map_params $exit->msg; 2718 my $rmp = parse_random_map_params $exit->msg;
… …
1903 if ($exit->map) { 2720 if ($exit->map) {
1904 $rmp->{region} = $exit->region->name; 2721 $rmp->{region} = $exit->region->name;
1905 $rmp->{origin_map} = $exit->map->path; 2722 $rmp->{origin_map} = $exit->map->path;
1906 $rmp->{origin_x} = $exit->x; 2723 $rmp->{origin_x} = $exit->x;
1907 $rmp->{origin_y} = $exit->y; 2724 $rmp->{origin_y} = $exit->y;
2725
2726 $exit->map->touch;
1908 } 2727 }
1909 2728
1910 $rmp->{random_seed} ||= $exit->random_seed; 2729 $rmp->{random_seed} ||= $exit->random_seed;
1911 2730
1912 my $data = cf::to_json $rmp; 2731 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
1913 my $md5 = Digest::MD5::md5_hex $data; 2732 my $md5 = Digest::MD5::md5_hex $data;
1914 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2733 my $meta = "$RANDOMDIR/$md5.meta";
1915 2734
1916 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2735 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1917 aio_write $fh, 0, (length $data), $data, 0; 2736 aio_write $fh, 0, (length $data), $data, 0;
1918 undef $fh; 2737 undef $fh;
1919 aio_rename "$meta~", $meta; 2738 aio_rename "$meta~", $meta;
1920 2739
2740 my $slaying = "?random/$md5";
2741
2742 if ($exit->valid) {
1921 $exit->slaying ("?random/$md5"); 2743 $exit->slaying ("?random/$md5");
1922 $exit->msg (undef); 2744 $exit->msg (undef);
2745 }
1923 } 2746 }
1924} 2747}
1925 2748
1926sub cf::object::player::enter_exit { 2749sub cf::object::player::enter_exit {
1927 my ($self, $exit) = @_; 2750 my ($self, $exit) = @_;
1928 2751
1929 return unless $self->type == cf::PLAYER; 2752 return unless $self->type == cf::PLAYER;
1930 2753
1931 if ($exit->slaying eq "/!") {
1932 #TODO: this should de-fi-ni-te-ly not be a sync-job
1933 cf::sync_job { prepare_random_map $exit };
1934 }
1935
1936 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1937 my $hp = $exit->stats->hp;
1938 my $sp = $exit->stats->sp;
1939
1940 $self->enter_link; 2754 $self->enter_link;
1941 2755
1942 (async { 2756 (async {
1943 $self->deactivate_recursive; # just to be sure 2757 $Coro::current->{desc} = "enter_exit";
2758
1944 unless (eval { 2759 unless (eval {
2760 $self->deactivate_recursive; # just to be sure
2761
2762 # random map handling
2763 {
2764 my $guard = cf::lock_acquire "exit_prepare:$exit";
2765
2766 prepare_random_map $exit
2767 if $exit->slaying eq "/!";
2768 }
2769
2770 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2771 my $x = $exit->stats->hp;
2772 my $y = $exit->stats->sp;
2773
1945 $self->goto ($slaying, $hp, $sp); 2774 $self->goto ($map, $x, $y);
1946 2775
2776 # if exit is damned, update players death & WoR home-position
2777 $self->contr->savebed ($map, $x, $y)
2778 if $exit->flag (cf::FLAG_DAMNED);
2779
1947 1; 2780 1
1948 }) { 2781 }) {
1949 $self->message ("Something went wrong deep within the crossfire server. " 2782 $self->message ("Something went wrong deep within the crossfire server. "
1950 . "I'll try to bring you back to the map you were before. " 2783 . "I'll try to bring you back to the map you were before. "
1951 . "Please report this to the dungeon master!", 2784 . "Please report this to the dungeon master!",
1952 cf::NDI_UNIQUE | cf::NDI_RED); 2785 cf::NDI_UNIQUE | cf::NDI_RED);
1953 2786
1954 warn "ERROR in enter_exit: $@"; 2787 warn "ERROR in enter_exit: $@";
1955 $self->leave_link; 2788 $self->leave_link;
1956 } 2789 }
1957 })->prio (1); 2790 })->prio (1);
… …
1970 2803
1971sub cf::client::send_drawinfo { 2804sub cf::client::send_drawinfo {
1972 my ($self, $text, $flags) = @_; 2805 my ($self, $text, $flags) = @_;
1973 2806
1974 utf8::encode $text; 2807 utf8::encode $text;
1975 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2808 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1976} 2809}
1977 2810
2811=item $client->send_msg ($channel, $msg, $color, [extra...])
2812
2813Send a drawinfo or msg packet to the client, formatting the msg for the
2814client if neccessary. C<$type> should be a string identifying the type of
2815the message, with C<log> being the default. If C<$color> is negative, suppress
2816the message unless the client supports the msg packet.
2817
2818=cut
2819
2820# non-persistent channels (usually the info channel)
2821our %CHANNEL = (
2822 "c/identify" => {
2823 id => "infobox",
2824 title => "Identify",
2825 reply => undef,
2826 tooltip => "Items recently identified",
2827 },
2828 "c/examine" => {
2829 id => "infobox",
2830 title => "Examine",
2831 reply => undef,
2832 tooltip => "Signs and other items you examined",
2833 },
2834 "c/book" => {
2835 id => "infobox",
2836 title => "Book",
2837 reply => undef,
2838 tooltip => "The contents of a note or book",
2839 },
2840 "c/lookat" => {
2841 id => "infobox",
2842 title => "Look",
2843 reply => undef,
2844 tooltip => "What you saw there",
2845 },
2846 "c/who" => {
2847 id => "infobox",
2848 title => "Players",
2849 reply => undef,
2850 tooltip => "Shows players who are currently online",
2851 },
2852 "c/body" => {
2853 id => "infobox",
2854 title => "Body Parts",
2855 reply => undef,
2856 tooltip => "Shows which body parts you posess and are available",
2857 },
2858 "c/uptime" => {
2859 id => "infobox",
2860 title => "Uptime",
2861 reply => undef,
2862 tooltip => "How long the server has been running since last restart",
2863 },
2864 "c/mapinfo" => {
2865 id => "infobox",
2866 title => "Map Info",
2867 reply => undef,
2868 tooltip => "Information related to the maps",
2869 },
2870 "c/party" => {
2871 id => "party",
2872 title => "Party",
2873 reply => "gsay ",
2874 tooltip => "Messages and chat related to your party",
2875 },
2876);
2877
2878sub cf::client::send_msg {
2879 my ($self, $channel, $msg, $color, @extra) = @_;
2880
2881 $msg = $self->pl->expand_cfpod ($msg);
2882
2883 $color &= cf::NDI_CLIENT_MASK; # just in case...
2884
2885 # check predefined channels, for the benefit of C
2886 if ($CHANNEL{$channel}) {
2887 $channel = $CHANNEL{$channel};
2888
2889 $self->ext_msg (channel_info => $channel)
2890 if $self->can_msg;
2891
2892 $channel = $channel->{id};
2893
2894 } elsif (ref $channel) {
2895 # send meta info to client, if not yet sent
2896 unless (exists $self->{channel}{$channel->{id}}) {
2897 $self->{channel}{$channel->{id}} = $channel;
2898 $self->ext_msg (channel_info => $channel)
2899 if $self->can_msg;
2900 }
2901
2902 $channel = $channel->{id};
2903 }
2904
2905 return unless @extra || length $msg;
2906
2907 if ($self->can_msg) {
2908 # default colour, mask it out
2909 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2910 if $color & cf::NDI_DEF;
2911
2912 $self->send_packet ("msg " . $self->{json_coder}->encode (
2913 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2914 } else {
2915 if ($color >= 0) {
2916 # replace some tags by gcfclient-compatible ones
2917 for ($msg) {
2918 1 while
2919 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2920 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2921 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2922 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2923 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2924 }
2925
2926 $color &= cf::NDI_COLOR_MASK;
2927
2928 utf8::encode $msg;
2929
2930 if (0 && $msg =~ /\[/) {
2931 # COMMAND/INFO
2932 $self->send_packet ("drawextinfo $color 10 8 $msg")
2933 } else {
2934 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2935 $self->send_packet ("drawinfo $color $msg")
2936 }
2937 }
2938 }
2939}
2940
2941=item $client->ext_msg ($type, @msg)
2942
2943Sends an ext event to the client.
2944
2945=cut
2946
2947sub cf::client::ext_msg($$@) {
2948 my ($self, $type, @msg) = @_;
2949
2950 if ($self->extcmd == 2) {
2951 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2952 } elsif ($self->extcmd == 1) { # TODO: remove
2953 push @msg, msgtype => "event_$type";
2954 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2955 }
2956}
2957
2958=item $client->ext_reply ($msgid, @msg)
2959
2960Sends an ext reply to the client.
2961
2962=cut
2963
2964sub cf::client::ext_reply($$@) {
2965 my ($self, $id, @msg) = @_;
2966
2967 if ($self->extcmd == 2) {
2968 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2969 } elsif ($self->extcmd == 1) {
2970 #TODO: version 1, remove
2971 unshift @msg, msgtype => "reply", msgid => $id;
2972 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2973 }
2974}
1978 2975
1979=item $success = $client->query ($flags, "text", \&cb) 2976=item $success = $client->query ($flags, "text", \&cb)
1980 2977
1981Queues a query to the client, calling the given callback with 2978Queues a query to the client, calling the given callback with
1982the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2979the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1983C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2980C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1984 2981
1985Queries can fail, so check the return code. Or don't, as queries will become 2982Queries can fail, so check the return code. Or don't, as queries will
1986reliable at some point in the future. 2983become reliable at some point in the future.
1987 2984
1988=cut 2985=cut
1989 2986
1990sub cf::client::query { 2987sub cf::client::query {
1991 my ($self, $flags, $text, $cb) = @_; 2988 my ($self, $flags, $text, $cb) = @_;
… …
1999 utf8::encode $text; 2996 utf8::encode $text;
2000 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2997 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2001 2998
2002 $self->send_packet ($self->{query_queue}[0][0]) 2999 $self->send_packet ($self->{query_queue}[0][0])
2003 if @{ $self->{query_queue} } == 1; 3000 if @{ $self->{query_queue} } == 1;
3001
3002 1
2004} 3003}
2005 3004
2006cf::client->attach ( 3005cf::client->attach (
3006 on_connect => sub {
3007 my ($ns) = @_;
3008
3009 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
3010 },
2007 on_reply => sub { 3011 on_reply => sub {
2008 my ($ns, $msg) = @_; 3012 my ($ns, $msg) = @_;
2009 3013
2010 # this weird shuffling is so that direct followup queries 3014 # this weird shuffling is so that direct followup queries
2011 # get handled first 3015 # get handled first
… …
2023 } else { 3027 } else {
2024 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 3028 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2025 } 3029 }
2026 } 3030 }
2027 }, 3031 },
3032 on_exticmd => sub {
3033 my ($ns, $buf) = @_;
3034
3035 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3036
3037 if (ref $msg) {
3038 my ($type, $reply, @payload) =
3039 "ARRAY" eq ref $msg
3040 ? @$msg
3041 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3042
3043 my @reply;
3044
3045 if (my $cb = $EXTICMD{$type}) {
3046 @reply = $cb->($ns, @payload);
3047 }
3048
3049 $ns->ext_reply ($reply, @reply)
3050 if $reply;
3051
3052 } else {
3053 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3054 }
3055
3056 cf::override;
3057 },
2028); 3058);
2029 3059
2030=item $client->async (\&cb) 3060=item $client->async (\&cb)
2031 3061
2032Create a new coroutine, running the specified callback. The coroutine will 3062Create a new coroutine, running the specified callback. The coroutine will
… …
2073our $safe = new Safe "safe"; 3103our $safe = new Safe "safe";
2074our $safe_hole = new Safe::Hole; 3104our $safe_hole = new Safe::Hole;
2075 3105
2076$SIG{FPE} = 'IGNORE'; 3106$SIG{FPE} = 'IGNORE';
2077 3107
2078$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3108$safe->permit_only (Opcode::opset qw(
3109 :base_core :base_mem :base_orig :base_math
3110 grepstart grepwhile mapstart mapwhile
3111 sort time
3112));
2079 3113
2080# here we export the classes and methods available to script code 3114# here we export the classes and methods available to script code
2081 3115
2082=pod 3116=pod
2083 3117
2084The following fucntions and emthods are available within a safe environment: 3118The following functions and methods are available within a safe environment:
2085 3119
2086 cf::object contr pay_amount pay_player map 3120 cf::object
3121 contr pay_amount pay_player map x y force_find force_add destroy
3122 insert remove name archname title slaying race decrease split
3123
2087 cf::object::player player 3124 cf::object::player
2088 cf::player peaceful 3125 player
2089 cf::map trigger 3126
3127 cf::player
3128 peaceful
3129
3130 cf::map
3131 trigger
2090 3132
2091=cut 3133=cut
2092 3134
2093for ( 3135for (
2094 ["cf::object" => qw(contr pay_amount pay_player map)], 3136 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3137 insert remove inv nrof name archname title slaying race
3138 decrease split destroy change_exp)],
2095 ["cf::object::player" => qw(player)], 3139 ["cf::object::player" => qw(player)],
2096 ["cf::player" => qw(peaceful)], 3140 ["cf::player" => qw(peaceful)],
2097 ["cf::map" => qw(trigger)], 3141 ["cf::map" => qw(trigger)],
2098) { 3142) {
2099 no strict 'refs'; 3143 no strict 'refs';
… …
2170=back 3214=back
2171 3215
2172=cut 3216=cut
2173 3217
2174############################################################################# 3218#############################################################################
2175
2176=head2 EXTENSION DATABASE SUPPORT
2177
2178Crossfire maintains a very simple database for extension use. It can
2179currently store anything that can be serialised using Storable, which
2180excludes objects.
2181
2182The parameter C<$family> should best start with the name of the extension
2183using it, it should be unique.
2184
2185=over 4
2186
2187=item $value = cf::db_get $family => $key
2188
2189Returns a single value from the database.
2190
2191=item cf::db_put $family => $key => $value
2192
2193Stores the given C<$value> in the family.
2194
2195=cut
2196
2197our $DB;
2198
2199sub db_init {
2200 unless ($DB) {
2201 $DB = BDB::db_create $DB_ENV;
2202
2203 cf::sync_job {
2204 eval {
2205 $DB->set_flags (BDB::CHKSUM);
2206
2207 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2208 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2209 cf::cleanup "db_open(db): $!" if $!;
2210 };
2211 cf::cleanup "db_open(db): $@" if $@;
2212 };
2213
2214 my $path = cf::localdir . "/database.pst";
2215 if (stat $path) {
2216 cf::sync_job {
2217 my $pst = Storable::retrieve $path;
2218
2219 cf::db_put (board => data => $pst->{board});
2220 cf::db_put (guildrules => data => $pst->{guildrules});
2221 cf::db_put (rent => balance => $pst->{rent}{balance});
2222 BDB::db_env_txn_checkpoint $DB_ENV;
2223
2224 unlink $path;
2225 };
2226 }
2227 }
2228}
2229
2230sub db_get($$) {
2231 my $key = "$_[0]/$_[1]";
2232
2233 cf::sync_job {
2234 BDB::db_get $DB, undef, $key, my $data;
2235
2236 $! ? ()
2237 : Compress::LZF::sthaw $data
2238 }
2239}
2240
2241sub db_put($$$) {
2242 BDB::dbreq_pri 4;
2243 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
2244}
2245
2246#############################################################################
2247# the server's init and main functions 3219# the server's init and main functions
2248 3220
2249sub init_resources { 3221sub load_facedata($) {
2250 load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir 3222 my ($path) = @_;
3223
3224 # HACK to clear player env face cache, we need some signal framework
3225 # for this (global event?)
3226 %ext::player_env::MUSIC_FACE_CACHE = ();
3227
3228 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3229
3230 warn "loading facedata from $path\n";
3231
3232 my $facedata;
3233 0 < aio_load $path, $facedata
3234 or die "$path: $!";
3235
3236 $facedata = Coro::Storable::thaw $facedata;
3237
3238 $facedata->{version} == 2
3239 or cf::cleanup "$path: version mismatch, cannot proceed.";
3240
3241 # patch in the exptable
3242 $facedata->{resource}{"res/exp_table"} = {
3243 type => FT_RSRC,
3244 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3245 };
3246 cf::cede_to_tick;
3247
3248 {
3249 my $faces = $facedata->{faceinfo};
3250
3251 while (my ($face, $info) = each %$faces) {
3252 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3253
3254 cf::face::set_visibility $idx, $info->{visibility};
3255 cf::face::set_magicmap $idx, $info->{magicmap};
3256 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
3257 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3258
3259 cf::cede_to_tick;
3260 }
3261
3262 while (my ($face, $info) = each %$faces) {
3263 next unless $info->{smooth};
3264
3265 my $idx = cf::face::find $face
3266 or next;
3267
3268 if (my $smooth = cf::face::find $info->{smooth}) {
3269 cf::face::set_smooth $idx, $smooth;
3270 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3271 } else {
3272 warn "smooth face '$info->{smooth}' not found for face '$face'";
3273 }
3274
3275 cf::cede_to_tick;
3276 }
3277 }
3278
3279 {
3280 my $anims = $facedata->{animinfo};
3281
3282 while (my ($anim, $info) = each %$anims) {
3283 cf::anim::set $anim, $info->{frames}, $info->{facings};
3284 cf::cede_to_tick;
3285 }
3286
3287 cf::anim::invalidate_all; # d'oh
3288 }
3289
3290 {
3291 # TODO: for gcfclient pleasure, we should give resources
3292 # that gcfclient doesn't grok a >10000 face index.
3293 my $res = $facedata->{resource};
3294
3295 while (my ($name, $info) = each %$res) {
3296 if (defined $info->{type}) {
3297 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3298 my $data;
3299
3300 if ($info->{type} & 1) {
3301 # prepend meta info
3302
3303 my $meta = $enc->encode ({
3304 name => $name,
3305 %{ $info->{meta} || {} },
3306 });
3307
3308 $data = pack "(w/a*)*", $meta, $info->{data};
3309 } else {
3310 $data = $info->{data};
3311 }
3312
3313 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3314 cf::face::set_type $idx, $info->{type};
3315 } else {
3316 $RESOURCE{$name} = $info;
3317 }
3318
3319 cf::cede_to_tick;
3320 }
3321 }
3322
3323 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3324
3325 1
3326}
3327
3328cf::global->attach (on_resource_update => sub {
3329 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3330 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3331
3332 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3333 my $sound = $soundconf->{compat}[$_]
3334 or next;
3335
3336 my $face = cf::face::find "sound/$sound->[1]";
3337 cf::sound::set $sound->[0] => $face;
3338 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3339 }
3340
3341 while (my ($k, $v) = each %{$soundconf->{event}}) {
3342 my $face = cf::face::find "sound/$v";
3343 cf::sound::set $k => $face;
3344 }
3345 }
3346});
3347
3348register_exticmd fx_want => sub {
3349 my ($ns, $want) = @_;
3350
3351 while (my ($k, $v) = each %$want) {
3352 $ns->fx_want ($k, $v);
3353 }
3354};
3355
3356sub load_resource_file($) {
3357 my $guard = lock_acquire "load_resource_file";
3358
3359 my $status = load_resource_file_ $_[0];
3360 get_slot 0.1, 100;
3361 cf::arch::commit_load;
3362
3363 $status
3364}
3365
3366sub reload_regions {
3367 # HACK to clear player env face cache, we need some signal framework
3368 # for this (global event?)
3369 %ext::player_env::MUSIC_FACE_CACHE = ();
3370
3371 load_resource_file "$MAPDIR/regions"
2251 or die "unable to load regions file\n";#d# 3372 or die "unable to load regions file\n";
2252}
2253 3373
2254sub cfg_load { 3374 for (cf::region::list) {
3375 $_->{match} = qr/$_->{match}/
3376 if exists $_->{match};
3377 }
3378}
3379
3380sub reload_facedata {
3381 load_facedata "$DATADIR/facedata"
3382 or die "unable to load facedata\n";
3383}
3384
3385sub reload_archetypes {
3386 load_resource_file "$DATADIR/archetypes"
3387 or die "unable to load archetypes\n";
3388}
3389
3390sub reload_treasures {
3391 load_resource_file "$DATADIR/treasures"
3392 or die "unable to load treasurelists\n";
3393}
3394
3395sub reload_resources {
3396 warn "reloading resource files...\n";
3397
3398 reload_facedata;
3399 reload_archetypes;
3400 reload_regions;
3401 reload_treasures;
3402
3403 warn "finished reloading resource files\n";
3404}
3405
3406sub init {
3407 my $guard = freeze_mainloop;
3408
3409 evthread_start IO::AIO::poll_fileno;
3410
3411 reload_resources;
3412}
3413
3414sub reload_config {
2255 open my $fh, "<:utf8", cf::confdir . "/config" 3415 open my $fh, "<:utf8", "$CONFDIR/config"
2256 or return; 3416 or return;
2257 3417
2258 local $/; 3418 local $/;
2259 *CFG = YAML::Syck::Load <$fh>; 3419 *CFG = YAML::Load <$fh>;
2260 3420
2261 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3421 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2262 3422
2263 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3423 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2264 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3424 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
2270 }; 3430 };
2271 warn $@ if $@; 3431 warn $@ if $@;
2272 } 3432 }
2273} 3433}
2274 3434
2275sub init {
2276 init_resources;
2277}
2278
2279sub main { 3435sub main {
2280 # we must not ever block the main coroutine 3436 # we must not ever block the main coroutine
2281 local $Coro::idle = sub { 3437 local $Coro::idle = sub {
2282 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3438 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2283 (async { 3439 (async {
2284 Event::one_event; 3440 $Coro::current->{desc} = "IDLE BUG HANDLER";
3441 EV::loop EV::LOOP_ONESHOT;
2285 })->prio (Coro::PRIO_MAX); 3442 })->prio (Coro::PRIO_MAX);
2286 }; 3443 };
2287 3444
2288 cfg_load; 3445 {
3446 my $guard = freeze_mainloop;
3447 reload_config;
2289 db_init; 3448 db_init;
2290 load_extensions; 3449 load_extensions;
2291 3450
2292 $TICK_WATCHER->start; 3451 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3452 }
3453
2293 Event::loop; 3454 EV::loop;
2294} 3455}
2295 3456
2296############################################################################# 3457#############################################################################
2297# initialisation and cleanup 3458# initialisation and cleanup
2298 3459
2299# install some emergency cleanup handlers 3460# install some emergency cleanup handlers
2300BEGIN { 3461BEGIN {
3462 our %SIGWATCHER = ();
2301 for my $signal (qw(INT HUP TERM)) { 3463 for my $signal (qw(INT HUP TERM)) {
2302 Event->signal ( 3464 $SIGWATCHER{$signal} = EV::signal $signal, sub {
2303 reentrant => 0,
2304 data => WF_AUTOCANCEL,
2305 signal => $signal,
2306 prio => 0,
2307 cb => sub {
2308 cf::cleanup "SIG$signal"; 3465 cf::cleanup "SIG$signal";
2309 },
2310 ); 3466 };
3467 }
3468}
3469
3470sub write_runtime_sync {
3471 my $runtime = "$LOCALDIR/runtime";
3472
3473 # first touch the runtime file to show we are still running:
3474 # the fsync below can take a very very long time.
3475
3476 IO::AIO::aio_utime $runtime, undef, undef;
3477
3478 my $guard = cf::lock_acquire "write_runtime";
3479
3480 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3481 or return;
3482
3483 my $value = $cf::RUNTIME + 90 + 10;
3484 # 10 is the runtime save interval, for a monotonic clock
3485 # 60 allows for the watchdog to kill the server.
3486
3487 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3488 and return;
3489
3490 # always fsync - this file is important
3491 aio_fsync $fh
3492 and return;
3493
3494 # touch it again to show we are up-to-date
3495 aio_utime $fh, undef, undef;
3496
3497 close $fh
3498 or return;
3499
3500 aio_rename "$runtime~", $runtime
3501 and return;
3502
3503 warn "runtime file written.\n";
3504
2311 } 3505 1
3506}
3507
3508our $uuid_lock;
3509our $uuid_skip;
3510
3511sub write_uuid_sync($) {
3512 $uuid_skip ||= $_[0];
3513
3514 return if $uuid_lock;
3515 local $uuid_lock = 1;
3516
3517 my $uuid = "$LOCALDIR/uuid";
3518
3519 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3520 or return;
3521
3522 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;
3523 $uuid_skip = 0;
3524
3525 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3526 and return;
3527
3528 # always fsync - this file is important
3529 aio_fsync $fh
3530 and return;
3531
3532 close $fh
3533 or return;
3534
3535 aio_rename "$uuid~", $uuid
3536 and return;
3537
3538 warn "uuid file written ($value).\n";
3539
3540 1
3541
3542}
3543
3544sub write_uuid($$) {
3545 my ($skip, $sync) = @_;
3546
3547 $sync ? write_uuid_sync $skip
3548 : async { write_uuid_sync $skip };
2312} 3549}
2313 3550
2314sub emergency_save() { 3551sub emergency_save() {
2315 my $freeze_guard = cf::freeze_mainloop; 3552 my $freeze_guard = cf::freeze_mainloop;
2316 3553
… …
2322 # and maps saved/destroyed asynchronously. 3559 # and maps saved/destroyed asynchronously.
2323 warn "begin emergency player save\n"; 3560 warn "begin emergency player save\n";
2324 for my $login (keys %cf::PLAYER) { 3561 for my $login (keys %cf::PLAYER) {
2325 my $pl = $cf::PLAYER{$login} or next; 3562 my $pl = $cf::PLAYER{$login} or next;
2326 $pl->valid or next; 3563 $pl->valid or next;
3564 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2327 $pl->save; 3565 $pl->save;
2328 } 3566 }
2329 warn "end emergency player save\n"; 3567 warn "end emergency player save\n";
2330 3568
2331 warn "begin emergency map save\n"; 3569 warn "begin emergency map save\n";
… …
2337 warn "end emergency map save\n"; 3575 warn "end emergency map save\n";
2338 3576
2339 warn "begin emergency database checkpoint\n"; 3577 warn "begin emergency database checkpoint\n";
2340 BDB::db_env_txn_checkpoint $DB_ENV; 3578 BDB::db_env_txn_checkpoint $DB_ENV;
2341 warn "end emergency database checkpoint\n"; 3579 warn "end emergency database checkpoint\n";
3580
3581 warn "begin write uuid\n";
3582 write_uuid_sync 1;
3583 warn "end write uuid\n";
2342 }; 3584 };
2343 3585
2344 warn "leave emergency perl save\n"; 3586 warn "leave emergency perl save\n";
2345} 3587}
2346 3588
… …
2349 3591
2350 warn Carp::longmess "post_cleanup backtrace" 3592 warn Carp::longmess "post_cleanup backtrace"
2351 if $make_core; 3593 if $make_core;
2352} 3594}
2353 3595
3596# a safer delete_package, copied from Symbol
3597sub clear_package($) {
3598 my $pkg = shift;
3599
3600 # expand to full symbol table name if needed
3601 unless ($pkg =~ /^main::.*::$/) {
3602 $pkg = "main$pkg" if $pkg =~ /^::/;
3603 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3604 $pkg .= '::' unless $pkg =~ /::$/;
3605 }
3606
3607 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3608 my $stem_symtab = *{$stem}{HASH};
3609
3610 defined $stem_symtab and exists $stem_symtab->{$leaf}
3611 or return;
3612
3613 # clear all symbols
3614 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3615 for my $name (keys %$leaf_symtab) {
3616 _gv_clear *{"$pkg$name"};
3617# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3618 }
3619 warn "cleared package #$pkg\n";#d#
3620}
3621
3622our $RELOAD; # how many times to reload
3623
2354sub reload() { 3624sub do_reload_perl() {
2355 # can/must only be called in main 3625 # can/must only be called in main
2356 if ($Coro::current != $Coro::main) { 3626 if ($Coro::current != $Coro::main) {
2357 warn "can only reload from main coroutine"; 3627 warn "can only reload from main coroutine";
2358 return; 3628 return;
2359 } 3629 }
2360 3630
3631 return if $RELOAD++;
3632
3633 while ($RELOAD) {
2361 warn "reloading..."; 3634 warn "reloading...";
2362 3635
2363 warn "entering sync_job"; 3636 warn "entering sync_job";
2364 3637
2365 cf::sync_job { 3638 cf::sync_job {
2366 cf::write_runtime; # external watchdog should not bark 3639 cf::write_runtime_sync; # external watchdog should not bark
2367 cf::emergency_save; 3640 cf::emergency_save;
2368 cf::write_runtime; # external watchdog should not bark 3641 cf::write_runtime_sync; # external watchdog should not bark
2369 3642
2370 warn "syncing database to disk"; 3643 warn "syncing database to disk";
2371 BDB::db_env_txn_checkpoint $DB_ENV; 3644 BDB::db_env_txn_checkpoint $DB_ENV;
2372 3645
2373 # if anything goes wrong in here, we should simply crash as we already saved 3646 # if anything goes wrong in here, we should simply crash as we already saved
2374 3647
2375 warn "cancelling all WF_AUTOCANCEL watchers";
2376 for (Event::all_watchers) {
2377 $_->cancel if $_->data & WF_AUTOCANCEL;
2378 }
2379
2380 warn "flushing outstanding aio requests"; 3648 warn "flushing outstanding aio requests";
2381 for (;;) {
2382 BDB::flush;
2383 IO::AIO::flush;
2384 Coro::cede;
2385 last unless IO::AIO::nreqs || BDB::nreqs; 3649 while (IO::AIO::nreqs || BDB::nreqs) {
2386 warn "iterate..."; 3650 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
2387 }
2388
2389 warn "cancelling all extension coros";
2390 $_->cancel for values %EXT_CORO;
2391 %EXT_CORO = ();
2392
2393 warn "removing commands";
2394 %COMMAND = ();
2395
2396 warn "removing ext commands";
2397 %EXTCMD = ();
2398
2399 warn "unloading/nuking all extensions";
2400 for my $pkg (@EXTS) {
2401 warn "... unloading $pkg";
2402
2403 if (my $cb = $pkg->can ("unload")) {
2404 eval {
2405 $cb->($pkg);
2406 1
2407 } or warn "$pkg unloaded, but with errors: $@";
2408 } 3651 }
2409 3652
2410 warn "... nuking $pkg"; 3653 warn "cancelling all extension coros";
2411 Symbol::delete_package $pkg; 3654 $_->cancel for values %EXT_CORO;
2412 } 3655 %EXT_CORO = ();
2413 3656
2414 warn "unloading all perl modules loaded from $LIBDIR"; 3657 warn "removing commands";
2415 while (my ($k, $v) = each %INC) { 3658 %COMMAND = ();
2416 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2417 3659
3660 warn "removing ext/exti commands";
3661 %EXTCMD = ();
3662 %EXTICMD = ();
3663
3664 warn "unloading/nuking all extensions";
3665 for my $pkg (@EXTS) {
2418 warn "... unloading $k"; 3666 warn "... unloading $pkg";
2419 delete $INC{$k};
2420 3667
2421 $k =~ s/\.pm$//;
2422 $k =~ s/\//::/g;
2423
2424 if (my $cb = $k->can ("unload_module")) { 3668 if (my $cb = $pkg->can ("unload")) {
3669 eval {
2425 $cb->(); 3670 $cb->($pkg);
3671 1
3672 } or warn "$pkg unloaded, but with errors: $@";
3673 }
3674
3675 warn "... clearing $pkg";
3676 clear_package $pkg;
2426 } 3677 }
2427 3678
2428 Symbol::delete_package $k; 3679 warn "unloading all perl modules loaded from $LIBDIR";
3680 while (my ($k, $v) = each %INC) {
3681 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3682
3683 warn "... unloading $k";
3684 delete $INC{$k};
3685
3686 $k =~ s/\.pm$//;
3687 $k =~ s/\//::/g;
3688
3689 if (my $cb = $k->can ("unload_module")) {
3690 $cb->();
3691 }
3692
3693 clear_package $k;
2429 } 3694 }
2430 3695
2431 warn "getting rid of safe::, as good as possible"; 3696 warn "getting rid of safe::, as good as possible";
2432 Symbol::delete_package "safe::$_" 3697 clear_package "safe::$_"
2433 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3698 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2434 3699
2435 warn "unloading cf.pm \"a bit\""; 3700 warn "unloading cf.pm \"a bit\"";
2436 delete $INC{"cf.pm"}; 3701 delete $INC{"cf.pm"};
3702 delete $INC{"cf/pod.pm"};
2437 3703
2438 # don't, removes xs symbols, too, 3704 # don't, removes xs symbols, too,
2439 # and global variables created in xs 3705 # and global variables created in xs
2440 #Symbol::delete_package __PACKAGE__; 3706 #clear_package __PACKAGE__;
2441 3707
2442 warn "unload completed, starting to reload now"; 3708 warn "unload completed, starting to reload now";
2443 3709
2444 warn "reloading cf.pm"; 3710 warn "reloading cf.pm";
2445 require cf; 3711 require cf;
2446 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3712 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2447 3713
2448 warn "loading config and database again"; 3714 warn "loading config and database again";
2449 cf::cfg_load; 3715 cf::reload_config;
2450 3716
2451 warn "loading extensions"; 3717 warn "loading extensions";
2452 cf::load_extensions; 3718 cf::load_extensions;
2453 3719
2454 warn "reattaching attachments to objects/players"; 3720 warn "reattaching attachments to objects/players";
2455 _global_reattach; 3721 _global_reattach; # objects, sockets
2456 warn "reattaching attachments to maps"; 3722 warn "reattaching attachments to maps";
2457 reattach $_ for values %MAP; 3723 reattach $_ for values %MAP;
3724 warn "reattaching attachments to players";
3725 reattach $_ for values %PLAYER;
2458 3726
2459 warn "loading reloadable resources";
2460 init_resources;
2461
2462 warn "leaving sync_job"; 3727 warn "leaving sync_job";
2463 3728
2464 1 3729 1
2465 } or do { 3730 } or do {
2466 warn $@; 3731 warn $@;
2467 warn "error while reloading, exiting."; 3732 cf::cleanup "error while reloading, exiting.";
2468 exit 1; 3733 };
3734
3735 warn "reloaded";
3736 --$RELOAD;
3737 }
3738};
3739
3740our $RELOAD_WATCHER; # used only during reload
3741
3742sub reload_perl() {
3743 # doing reload synchronously and two reloads happen back-to-back,
3744 # coro crashes during coro_state_free->destroy here.
3745
3746 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3747 do_reload_perl;
3748 undef $RELOAD_WATCHER;
2469 }; 3749 };
2470 3750}
2471 warn "reloaded";
2472};
2473
2474our $RELOAD_WATCHER; # used only during reload
2475 3751
2476register_command "reload" => sub { 3752register_command "reload" => sub {
2477 my ($who, $arg) = @_; 3753 my ($who, $arg) = @_;
2478 3754
2479 if ($who->flag (FLAG_WIZ)) { 3755 if ($who->flag (FLAG_WIZ)) {
2480 $who->message ("reloading server."); 3756 $who->message ("reloading server.");
2481 3757 async {
2482 # doing reload synchronously and two reloads happen back-to-back, 3758 $Coro::current->{desc} = "perl_reload";
2483 # coro crashes during coro_state_free->destroy here.
2484
2485 $RELOAD_WATCHER ||= Event->timer (
2486 reentrant => 0,
2487 after => 0,
2488 data => WF_AUTOCANCEL,
2489 cb => sub {
2490 reload; 3759 reload_perl;
2491 undef $RELOAD_WATCHER;
2492 },
2493 ); 3760 };
2494 } 3761 }
2495}; 3762};
2496 3763
2497unshift @INC, $LIBDIR; 3764unshift @INC, $LIBDIR;
2498 3765
2499my $bug_warning = 0; 3766my $bug_warning = 0;
2500 3767
2501$TICK_WATCHER = Event->timer ( 3768our @WAIT_FOR_TICK;
2502 reentrant => 0, 3769our @WAIT_FOR_TICK_BEGIN;
2503 parked => 1, 3770
2504 prio => 0, 3771sub wait_for_tick {
2505 at => $NEXT_TICK || $TICK, 3772 return if tick_inhibit || $Coro::current == $Coro::main;
2506 data => WF_AUTOCANCEL, 3773
2507 cb => sub { 3774 my $signal = new Coro::Signal;
3775 push @WAIT_FOR_TICK, $signal;
3776 $signal->wait;
3777}
3778
3779sub wait_for_tick_begin {
3780 return if tick_inhibit || $Coro::current == $Coro::main;
3781
3782 my $signal = new Coro::Signal;
3783 push @WAIT_FOR_TICK_BEGIN, $signal;
3784 $signal->wait;
3785}
3786
3787sub tick {
2508 if ($Coro::current != $Coro::main) { 3788 if ($Coro::current != $Coro::main) {
2509 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3789 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2510 unless ++$bug_warning > 10; 3790 unless ++$bug_warning > 10;
2511 return; 3791 return;
2512 } 3792 }
2513 3793
2514 $NOW = Event::time;
2515
2516 cf::server_tick; # one server iteration 3794 cf::server_tick; # one server iteration
2517 $RUNTIME += $TICK;
2518 $NEXT_TICK += $TICK;
2519 3795
2520 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3796 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2521 $NEXT_RUNTIME_WRITE = $NOW + 10; 3797 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2522 Coro::async_pool { 3798 Coro::async_pool {
3799 $Coro::current->{desc} = "runtime saver";
2523 write_runtime 3800 write_runtime_sync
2524 or warn "ERROR: unable to write runtime file: $!"; 3801 or warn "ERROR: unable to write runtime file: $!";
2525 };
2526 } 3802 };
2527
2528 $WAIT_FOR_TICK->broadcast;
2529 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2530
2531# my $AFTER = Event::time;
2532# warn $AFTER - $NOW;#d#
2533
2534 # if we are delayed by four ticks or more, skip them all
2535 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2536
2537 $TICK_WATCHER->at ($NEXT_TICK);
2538 $TICK_WATCHER->start;
2539 }, 3803 }
2540); 3804
3805 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3806 $sig->send;
3807 }
3808 while (my $sig = shift @WAIT_FOR_TICK) {
3809 $sig->send;
3810 }
3811
3812 $LOAD = ($NOW - $TICK_START) / $TICK;
3813 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3814
3815 if (0) {
3816 if ($NEXT_TICK) {
3817 my $jitter = $TICK_START - $NEXT_TICK;
3818 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3819 warn "jitter $JITTER\n";#d#
3820 }
3821 }
3822}
2541 3823
2542{ 3824{
2543 BDB::max_poll_time $TICK * 0.1; 3825 # configure BDB
2544 $BDB_POLL_WATCHER = Event->io ( 3826
2545 reentrant => 0,
2546 fd => BDB::poll_fileno,
2547 poll => 'r',
2548 prio => 0,
2549 data => WF_AUTOCANCEL,
2550 cb => \&BDB::poll_cb,
2551 );
2552 BDB::min_parallel 8; 3827 BDB::min_parallel 8;
2553 3828 BDB::max_poll_reqs $TICK * 0.1;
2554 BDB::set_sync_prepare { 3829 $AnyEvent::BDB::WATCHER->priority (1);
2555 my $status;
2556 my $current = $Coro::current;
2557 (
2558 sub {
2559 $status = $!;
2560 $current->ready; undef $current;
2561 },
2562 sub {
2563 Coro::schedule while defined $current;
2564 $! = $status;
2565 },
2566 )
2567 };
2568 3830
2569 unless ($DB_ENV) { 3831 unless ($DB_ENV) {
2570 $DB_ENV = BDB::db_env_create; 3832 $DB_ENV = BDB::db_env_create;
3833 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3834 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3835 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3836 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3837 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
2571 3838
2572 cf::sync_job { 3839 cf::sync_job {
2573 eval { 3840 eval {
2574 BDB::db_env_open 3841 BDB::db_env_open
2575 $DB_ENV, 3842 $DB_ENV,
2576 $BDB_ENV_DIR, 3843 $BDBDIR,
2577 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3844 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2578 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3845 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2579 0666; 3846 0666;
2580 3847
2581 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!; 3848 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2582
2583 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2584 $DB_ENV->set_lk_detect;
2585 }; 3849 };
2586 3850
2587 cf::cleanup "db_env_open(db): $@" if $@; 3851 cf::cleanup "db_env_open(db): $@" if $@;
2588 }; 3852 };
2589 } 3853 }
3854
3855 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3856 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3857 };
3858 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3859 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3860 };
3861 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3862 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3863 };
2590} 3864}
2591 3865
2592{ 3866{
3867 # configure IO::AIO
3868
2593 IO::AIO::min_parallel 8; 3869 IO::AIO::min_parallel 8;
2594
2595 undef $Coro::AIO::WATCHER;
2596 IO::AIO::max_poll_time $TICK * 0.1; 3870 IO::AIO::max_poll_time $TICK * 0.1;
2597 $AIO_POLL_WATCHER = Event->io ( 3871 undef $AnyEvent::AIO::WATCHER;
2598 reentrant => 0,
2599 data => WF_AUTOCANCEL,
2600 fd => IO::AIO::poll_fileno,
2601 poll => 'r',
2602 prio => 6,
2603 cb => \&IO::AIO::poll_cb,
2604 );
2605} 3872}
3873
3874my $_log_backtrace;
3875
3876sub _log_backtrace {
3877 my ($msg, @addr) = @_;
3878
3879 $msg =~ s/\n//;
3880
3881 # limit the # of concurrent backtraces
3882 if ($_log_backtrace < 2) {
3883 ++$_log_backtrace;
3884 async {
3885 $Coro::current->{desc} = "abt $msg";
3886
3887 my @bt = fork_call {
3888 @addr = map { sprintf "%x", $_ } @addr;
3889 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3890 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3891 or die "addr2line: $!";
3892
3893 my @funcs;
3894 my @res = <$fh>;
3895 chomp for @res;
3896 while (@res) {
3897 my ($func, $line) = splice @res, 0, 2, ();
3898 push @funcs, "[$func] $line";
3899 }
3900
3901 @funcs
3902 };
3903
3904 LOG llevInfo, "[ABT] $msg\n";
3905 LOG llevInfo, "[ABT] $_\n" for @bt;
3906 --$_log_backtrace;
3907 };
3908 } else {
3909 LOG llevInfo, "[ABT] $msg\n";
3910 LOG llevInfo, "[ABT] [suppressed]\n";
3911 }
3912}
3913
3914# load additional modules
3915use cf::pod;
2606 3916
2607END { cf::emergency_save } 3917END { cf::emergency_save }
2608 3918
26091 39191
2610 3920

Diff Legend

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