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

Diff Legend

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