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

Diff Legend

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