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.168 by root, Sun Jan 14 00:37:14 2007 UTC vs.
Revision 1.507 by root, Sat Mar 20 02:24:38 2010 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008,2009,2010 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.3 (); 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 + 1 + 10; # 10 is the runtime save interval, for a monotonic clock 574=cut
355 (aio_write $fh, 0, (length $value), $value, 0) <= 0
356 and return;
357 575
358 aio_fsync $fh 576sub fork_call(&@) {
359 and return; 577 my ($cb, @args) = @_;
360 578
361 close $fh 579 # we seemingly have to make a local copy of the whole thing,
362 or return; 580 # otherwise perl prematurely frees the stuff :/
581 # TODO: investigate and fix (likely this will be rather laborious)
363 582
364 aio_rename "$runtime~", $runtime 583 my @res = Coro::Util::fork_eval {
365 and return; 584 reset_signals;
585 &$cb
586 }, @args;
366 587
588 wantarray ? @res : $res[-1]
589}
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
367 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 });
368} 754}
369 755
370=back 756=back
371 757
372=cut 758=cut
373 759
374############################################################################# 760#############################################################################
375 761
376=head2 ATTACHABLE OBJECTS 762=head2 ATTACHABLE OBJECTS
377 763
378Many 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
379attach callbacks/event handlers (a collection of which is called an "attachment") 765attach callbacks/event handlers (a collection of which is called an "attachment")
380to it. All such attachable objects support the following methods. 766to it. All such attachable objects support the following methods.
381 767
382In 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>
383C<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
384crossfire+). 770Deliantra).
385 771
386=over 4 772=over 4
387 773
388=item $attachable->attach ($attachment, key => $value...) 774=item $attachable->attach ($attachment, key => $value...)
389 775
… …
433=item cf::CLASS::attachment $name, ... 819=item cf::CLASS::attachment $name, ...
434 820
435Register an attachment by C<$name> through which attachable objects of the 821Register an attachment by C<$name> through which attachable objects of the
436given CLASS can refer to this attachment. 822given CLASS can refer to this attachment.
437 823
438Some classes such as crossfire maps and objects can specify attachments 824Some classes such as deliantra maps and objects can specify attachments
439that 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.
440 826
441These calls expect any number of the following handler/hook descriptions: 827These calls expect any number of the following handler/hook descriptions:
442 828
443=over 4 829=over 4
… …
503our @CB_TYPE = (); # registry for type (cf-object class) based events 889our @CB_TYPE = (); # registry for type (cf-object class) based events
504our @CB_MAP = (); 890our @CB_MAP = ();
505 891
506my %attachment; 892my %attachment;
507 893
894sub cf::attachable::thawer_merge {
895 # simply override everything except _meta
896 local $_[0]{_meta};
897 %{$_[0]} = %{$_[1]};
898}
899
508sub _attach_cb($$$$) { 900sub _attach_cb($$$$) {
509 my ($registry, $event, $prio, $cb) = @_; 901 my ($registry, $event, $prio, $cb) = @_;
510 902
511 use sort 'stable'; 903 use sort 'stable';
512 904
… …
546 $registry = $CB_TYPE[$object_type] ||= []; 938 $registry = $CB_TYPE[$object_type] ||= [];
547 939
548 } elsif ($type eq "subtype") { 940 } elsif ($type eq "subtype") {
549 defined $object_type or Carp::croak "subtype specified without type"; 941 defined $object_type or Carp::croak "subtype specified without type";
550 my $object_subtype = shift @arg; 942 my $object_subtype = shift @arg;
551 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 943 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
552 944
553 } elsif ($type eq "package") { 945 } elsif ($type eq "package") {
554 my $pkg = shift @arg; 946 my $pkg = shift @arg;
555 947
556 while (my ($name, $id) = each %cb_id) { 948 while (my ($name, $id) = each %cb_id) {
… …
585 _attach $registry, $klass, @attach; 977 _attach $registry, $klass, @attach;
586 } 978 }
587 979
588 $obj->{$name} = \%arg; 980 $obj->{$name} = \%arg;
589 } else { 981 } else {
590 warn "object uses attachment '$name' that is not available, postponing.\n"; 982 warn "object uses attachment '$name' which is not available, postponing.\n";
591 } 983 }
592 984
593 $obj->{_attachment}{$name} = undef; 985 $obj->{_attachment}{$name} = undef;
594} 986}
595 987
… …
597 if (ref $_[0]) { 989 if (ref $_[0]) {
598 _object_attach @_; 990 _object_attach @_;
599 } else { 991 } else {
600 _attach shift->_attach_registry, @_; 992 _attach shift->_attach_registry, @_;
601 } 993 }
994 _recalc_want;
602}; 995};
603 996
604# all those should be optimised 997# all those should be optimised
605sub cf::attachable::detach { 998sub cf::attachable::detach {
606 my ($obj, $name) = @_; 999 my ($obj, $name) = @_;
… …
609 delete $obj->{_attachment}{$name}; 1002 delete $obj->{_attachment}{$name};
610 reattach ($obj); 1003 reattach ($obj);
611 } else { 1004 } else {
612 Carp::croak "cannot, currently, detach class attachments"; 1005 Carp::croak "cannot, currently, detach class attachments";
613 } 1006 }
1007 _recalc_want;
614}; 1008};
615 1009
616sub cf::attachable::attached { 1010sub cf::attachable::attached {
617 my ($obj, $name) = @_; 1011 my ($obj, $name) = @_;
618 1012
… …
633 "; 1027 ";
634 die if $@; 1028 die if $@;
635} 1029}
636 1030
637our $override; 1031our $override;
638our @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?
639 1033
640sub override { 1034sub override {
641 $override = 1; 1035 $override = 1;
642 @invoke_results = (); 1036 @INVOKE_RESULTS = (@_);
643} 1037}
644 1038
645sub do_invoke { 1039sub do_invoke {
646 my $event = shift; 1040 my $event = shift;
647 my $callbacks = shift; 1041 my $callbacks = shift;
648 1042
649 @invoke_results = (); 1043 @INVOKE_RESULTS = ();
650 1044
651 local $override; 1045 local $override;
652 1046
653 for (@$callbacks) { 1047 for (@$callbacks) {
654 eval { &{$_->[1]} }; 1048 eval { &{$_->[1]} };
… …
663 } 1057 }
664 1058
665 0 1059 0
666} 1060}
667 1061
668=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1062=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
669 1063
670=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1064=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
671 1065
672Generate an object-specific event with the given arguments. 1066Generate an object-specific event with the given arguments.
673 1067
674This 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
675removed 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
676results (if you must, access C<@cf::invoke_results> directly). 1070results (if you must, access C<@cf::INVOKE_RESULTS> directly).
677 1071
678=back 1072=back
679 1073
680=cut 1074=cut
681 1075
682############################################################################# 1076#############################################################################
683# 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}
684 1120
685sub reattach { 1121sub reattach {
686 # basically do the same as instantiate, without calling instantiate 1122 # basically do the same as instantiate, without calling instantiate
687 my ($obj) = @_; 1123 my ($obj) = @_;
1124
1125 # no longer needed after getting rid of delete_package?
1126 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
688 1127
689 my $registry = $obj->registry; 1128 my $registry = $obj->registry;
690 1129
691 @$registry = (); 1130 @$registry = ();
692 1131
… …
707cf::attachable->attach ( 1146cf::attachable->attach (
708 prio => -1000000, 1147 prio => -1000000,
709 on_instantiate => sub { 1148 on_instantiate => sub {
710 my ($obj, $data) = @_; 1149 my ($obj, $data) = @_;
711 1150
712 $data = from_json $data; 1151 $data = decode_json $data;
713 1152
714 for (@$data) { 1153 for (@$data) {
715 my ($name, $args) = @$_; 1154 my ($name, $args) = @$_;
716 1155
717 $obj->attach ($name, %{$args || {} }); 1156 $obj->attach ($name, %{$args || {} });
… …
733sub object_freezer_save { 1172sub object_freezer_save {
734 my ($filename, $rdata, $objs) = @_; 1173 my ($filename, $rdata, $objs) = @_;
735 1174
736 sync_job { 1175 sync_job {
737 if (length $$rdata) { 1176 if (length $$rdata) {
1177 utf8::decode (my $decname = $filename);
738 warn sprintf "saving %s (%d,%d)\n", 1178 warn sprintf "saving %s (%d,%d)\n",
739 $filename, length $$rdata, scalar @$objs; 1179 $decname, length $$rdata, scalar @$objs;
740 1180
741 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1181 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
742 chmod SAVE_MODE, $fh; 1182 aio_chmod $fh, SAVE_MODE;
743 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;
744 aio_fsync $fh; 1186 aio_fsync $fh;
1187 }
745 close $fh; 1188 aio_close $fh;
746 1189
747 if (@$objs) { 1190 if (@$objs) {
748 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) {
749 chmod SAVE_MODE, $fh; 1192 aio_chmod $fh, SAVE_MODE;
750 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1193 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
751 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;
752 aio_fsync $fh; 1197 aio_fsync $fh;
1198 }
753 close $fh; 1199 aio_close $fh;
754 aio_rename "$filename.pst~", "$filename.pst"; 1200 aio_rename "$filename.pst~", "$filename.pst";
755 } 1201 }
756 } else { 1202 } else {
757 aio_unlink "$filename.pst"; 1203 aio_unlink "$filename.pst";
758 } 1204 }
759 1205
760 aio_rename "$filename~", $filename; 1206 aio_rename "$filename~", $filename;
1207
1208 $filename =~ s%/[^/]+$%%;
1209 aio_pathsync $filename if $cf::USE_FSYNC;
761 } else { 1210 } else {
762 warn "FATAL: $filename~: $!\n"; 1211 warn "unable to save objects: $filename~: $!\n";
763 } 1212 }
764 } else { 1213 } else {
765 aio_unlink $filename; 1214 aio_unlink $filename;
766 aio_unlink "$filename.pst"; 1215 aio_unlink "$filename.pst";
767 } 1216 }
768 } 1217 };
769} 1218}
770 1219
771sub object_freezer_as_string { 1220sub object_freezer_as_string {
772 my ($rdata, $objs) = @_; 1221 my ($rdata, $objs) = @_;
773 1222
… …
785 or return; 1234 or return;
786 1235
787 unless (aio_stat "$filename.pst") { 1236 unless (aio_stat "$filename.pst") {
788 (aio_load "$filename.pst", $av) >= 0 1237 (aio_load "$filename.pst", $av) >= 0
789 or return; 1238 or return;
1239
790 $av = eval { (Storable::thaw $av)->{objs} }; 1240 my $st = eval { Coro::Storable::thaw $av };
1241 $av = $st->{objs};
791 } 1242 }
792 1243
1244 utf8::decode (my $decname = $filename);
793 warn sprintf "loading %s (%d)\n", 1245 warn sprintf "loading %s (%d,%d)\n",
794 $filename, length $data, scalar @{$av || []};#d# 1246 $decname, length $data, scalar @{$av || []};
1247
795 return ($data, $av); 1248 ($data, $av)
796} 1249}
1250
1251=head2 COMMAND CALLBACKS
1252
1253=over 4
1254
1255=cut
797 1256
798############################################################################# 1257#############################################################################
799# command handling &c 1258# command handling &c
800 1259
801=item cf::register_command $name => \&callback($ob,$args); 1260=item cf::register_command $name => \&callback($ob,$args);
… …
814 push @{ $COMMAND{$name} }, [$caller, $cb]; 1273 push @{ $COMMAND{$name} }, [$caller, $cb];
815} 1274}
816 1275
817=item cf::register_extcmd $name => \&callback($pl,$packet); 1276=item cf::register_extcmd $name => \&callback($pl,$packet);
818 1277
819Register 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.
820 1283
821If 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
822called. 1285called.
823 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
824=cut 1298=cut
825 1299
826sub register_extcmd { 1300sub register_extcmd {
827 my ($name, $cb) = @_; 1301 my ($name, $cb) = @_;
828 1302
829 $EXTCMD{$name} = $cb; 1303 $EXTCMD{$name} = $cb;
830} 1304}
1305
1306sub register_exticmd {
1307 my ($name, $cb) = @_;
1308
1309 $EXTICMD{$name} = $cb;
1310}
1311
1312use File::Glob ();
831 1313
832cf::player->attach ( 1314cf::player->attach (
833 on_command => sub { 1315 on_command => sub {
834 my ($pl, $name, $params) = @_; 1316 my ($pl, $name, $params) = @_;
835 1317
… …
843 cf::override; 1325 cf::override;
844 }, 1326 },
845 on_extcmd => sub { 1327 on_extcmd => sub {
846 my ($pl, $buf) = @_; 1328 my ($pl, $buf) = @_;
847 1329
848 my $msg = eval { from_json $buf }; 1330 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
849 1331
850 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
851 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1340 if (my $cb = $EXTCMD{$type}) {
852 if (my %reply = $cb->($pl, $msg)) { 1341 @reply = $cb->($pl, @payload);
853 $pl->ext_reply ($msg->{msgid}, %reply);
854 }
855 } 1342 }
1343
1344 $pl->ext_reply ($reply, @reply)
1345 if $reply;
1346
856 } else { 1347 } else {
857 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1348 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
858 } 1349 }
859 1350
860 cf::override; 1351 cf::override;
861 }, 1352 },
862); 1353);
863 1354
1355# "readahead" all extensions
864sub load_extension { 1356sub cache_extensions {
865 my ($path) = @_; 1357 my $grp = IO::AIO::aio_group;
866 1358
867 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1359 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
868 my $base = $1; 1360 for (grep /\.ext$/, @{$_[0]}) {
869 my $pkg = $1; 1361 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
870 $pkg =~ s/[^[:word:]]/_/g;
871 $pkg = "ext::$pkg";
872
873 warn "... loading '$path' into '$pkg'\n";
874
875 open my $fh, "<:utf8", $path
876 or die "$path: $!";
877
878 my $source =
879 "package $pkg; use strict; use utf8;\n"
880 . "#line 1 \"$path\"\n{\n"
881 . (do { local $/; <$fh> })
882 . "\n};\n1";
883
884 unless (eval $source) {
885 my $msg = $@ ? "$path: $@\n"
886 : "extension disabled.\n";
887 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
888 warn $@;
889 warn "mandatory extension failed to load, exiting.\n";
890 exit 1;
891 } 1362 }
892 die $@;
893 } 1363 };
894 1364
895 push @EXTS, $pkg; 1365 $grp
896} 1366}
897 1367
898sub load_extensions { 1368sub load_extensions {
1369 cf::sync_job {
1370 my %todo;
1371
899 for my $ext (<$LIBDIR/*.ext>) { 1372 for my $path (<$LIBDIR/*.ext>) {
900 next unless -r $ext; 1373 next unless -r $path;
901 eval { 1374
902 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 $pass = 0;
1405 my %done;
1406 while (%todo) {
1407 my $progress;
1408
1409 ++$pass;
1410
1411 ext:
1412 while (my ($k, $v) = each %todo) {
1413 for (split /,\s*/, $v->{meta}{depends}) {
1414 next ext
1415 unless exists $done{$_};
1416 }
1417
1418 warn "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1419
1420 my $active = eval $v->{source};
1421
1422 if (length $@) {
1423 warn "$v->{path}: $@\n";
1424
1425 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1426 if exists $v->{meta}{mandatory};
1427 } else {
1428 $done{$k} = delete $todo{$k};
1429 push @EXTS, $v->{pkg};
1430 $progress = 1;
1431
1432 warn "$v->{base}: extension inactive.\n"
1433 unless $active;
1434 }
903 1 1435 }
904 } or warn "$ext not loaded: $@"; 1436
1437 unless ($progress) {
1438 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1439
1440 while (my ($k, $v) = each %todo) {
1441 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1442 if exists $v->{meta}{mandatory};
1443 }
1444 }
1445 }
905 } 1446 };
906} 1447}
907 1448
908############################################################################# 1449#############################################################################
909 1450
1451=back
1452
910=head2 CORE EXTENSIONS 1453=head2 CORE EXTENSIONS
911 1454
912Functions and methods that extend core crossfire objects. 1455Functions and methods that extend core deliantra objects.
913 1456
914=cut 1457=cut
915 1458
916package cf::player; 1459package cf::player;
917 1460
… …
919 1462
920=head3 cf::player 1463=head3 cf::player
921 1464
922=over 4 1465=over 4
923 1466
1467=item cf::player::num_playing
1468
1469Returns the official number of playing players, as per the Crossfire metaserver rules.
1470
1471=cut
1472
1473sub num_playing {
1474 scalar grep
1475 $_->ob->map
1476 && !$_->hidden
1477 && !$_->ob->flag (cf::FLAG_WIZ),
1478 cf::player::list
1479}
1480
924=item cf::player::find $login 1481=item cf::player::find $login
925 1482
926Returns the given player object, loading it if necessary (might block). 1483Returns the given player object, loading it if necessary (might block).
927 1484
928=cut 1485=cut
929 1486
930sub playerdir($) { 1487sub playerdir($) {
931 cf::localdir 1488 "$PLAYERDIR/"
932 . "/"
933 . cf::playerdir
934 . "/"
935 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1489 . (ref $_[0] ? $_[0]->ob->name : $_[0])
936} 1490}
937 1491
938sub path($) { 1492sub path($) {
939 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1493 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
940 1494
941 (playerdir $login) . "/$login.pl" 1495 (playerdir $login) . "/playerdata"
942} 1496}
943 1497
944sub find_active($) { 1498sub find_active($) {
945 $cf::PLAYER{$_[0]} 1499 $cf::PLAYER{$_[0]}
946 and $cf::PLAYER{$_[0]}->active 1500 and $cf::PLAYER{$_[0]}->active
… …
949 1503
950sub exists($) { 1504sub exists($) {
951 my ($login) = @_; 1505 my ($login) = @_;
952 1506
953 $cf::PLAYER{$login} 1507 $cf::PLAYER{$login}
954 or cf::sync_job { !aio_stat $login } 1508 or !aio_stat path $login
955} 1509}
956 1510
957sub find($) { 1511sub find($) {
958 return $cf::PLAYER{$_[0]} || do { 1512 return $cf::PLAYER{$_[0]} || do {
959 my $login = $_[0]; 1513 my $login = $_[0];
960 1514
961 my $guard = cf::lock_acquire "user_find:$login"; 1515 my $guard = cf::lock_acquire "user_find:$login";
962 1516
963 $cf::PLAYER{$_[0]} || do { 1517 $cf::PLAYER{$_[0]} || do {
964 my $pl = load_pl path $login 1518 # rename old playerfiles to new ones
1519 #TODO: remove when no longer required
1520 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1521 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1522 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1523 aio_unlink +(playerdir $login) . "/$login.pl";
1524
1525 my $f = new_from_file cf::object::thawer path $login
965 or return; 1526 or return;
1527
1528 my $pl = cf::player::load_pl $f
1529 or return;
1530
1531 local $cf::PLAYER_LOADING{$login} = $pl;
1532 $f->resolve_delayed_derefs;
966 $cf::PLAYER{$login} = $pl 1533 $cf::PLAYER{$login} = $pl
967 } 1534 }
968 } 1535 }
969} 1536}
970 1537
… …
979 return if $pl->{deny_save}; 1546 return if $pl->{deny_save};
980 1547
981 aio_mkdir playerdir $pl, 0770; 1548 aio_mkdir playerdir $pl, 0770;
982 $pl->{last_save} = $cf::RUNTIME; 1549 $pl->{last_save} = $cf::RUNTIME;
983 1550
1551 cf::get_slot 0.01;
1552
984 $pl->save_pl ($path); 1553 $pl->save_pl ($path);
985 Coro::cede; 1554 cf::cede_to_tick;
986} 1555}
987 1556
988sub new($) { 1557sub new($) {
989 my ($login) = @_; 1558 my ($login) = @_;
990 1559
… …
996 $cf::PLAYER{$login} = $self; 1565 $cf::PLAYER{$login} = $self;
997 1566
998 $self 1567 $self
999} 1568}
1000 1569
1570=item $player->send_msg ($channel, $msg, $color, [extra...])
1571
1572=cut
1573
1574sub send_msg {
1575 my $ns = shift->ns
1576 or return;
1577 $ns->send_msg (@_);
1578}
1579
1001=item $pl->quit_character 1580=item $pl->quit_character
1002 1581
1003Nukes the player without looking back. If logged in, the connection will 1582Nukes the player without looking back. If logged in, the connection will
1004be destroyed. May block for a long time. 1583be destroyed. May block for a long time.
1005 1584
1006=cut 1585=cut
1007 1586
1008sub quit_character { 1587sub quit_character {
1009 my ($pl) = @_; 1588 my ($pl) = @_;
1010 1589
1590 my $name = $pl->ob->name;
1591
1011 $pl->{deny_save} = 1; 1592 $pl->{deny_save} = 1;
1012 $pl->password ("*"); # this should lock out the player until we nuked the dir 1593 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1013 1594
1014 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1595 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1015 $pl->deactivate; 1596 $pl->deactivate;
1597 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1598 $pl->ob->check_score;
1016 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1599 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1017 $pl->ns->destroy if $pl->ns; 1600 $pl->ns->destroy if $pl->ns;
1018 1601
1019 my $path = playerdir $pl; 1602 my $path = playerdir $pl;
1020 my $temp = "$path~$cf::RUNTIME~deleting~"; 1603 my $temp = "$path~$cf::RUNTIME~deleting~";
1021 aio_rename $path, $temp; 1604 aio_rename $path, $temp;
1022 delete $cf::PLAYER{$pl->ob->name}; 1605 delete $cf::PLAYER{$pl->ob->name};
1023 $pl->destroy; 1606 $pl->destroy;
1607
1608 my $prefix = qr<^~\Q$name\E/>;
1609
1610 # nuke player maps
1611 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1612
1024 IO::AIO::aio_rmtree $temp; 1613 IO::AIO::aio_rmtree $temp;
1614}
1615
1616=item $pl->kick
1617
1618Kicks a player out of the game. This destroys the connection.
1619
1620=cut
1621
1622sub kick {
1623 my ($pl, $kicker) = @_;
1624
1625 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1626 $pl->killer ("kicked");
1627 $pl->ns->destroy;
1025} 1628}
1026 1629
1027=item cf::player::list_logins 1630=item cf::player::list_logins
1028 1631
1029Returns am arrayref of all valid playernames in the system, can take a 1632Returns am arrayref of all valid playernames in the system, can take a
1030while and may block, so not sync_job-capable, ever. 1633while and may block, so not sync_job-capable, ever.
1031 1634
1032=cut 1635=cut
1033 1636
1034sub list_logins { 1637sub list_logins {
1035 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1638 my $dirs = aio_readdir $PLAYERDIR
1036 or return []; 1639 or return [];
1037 1640
1038 my @logins; 1641 my @logins;
1039 1642
1040 for my $login (@$dirs) { 1643 for my $login (@$dirs) {
1644 my $path = path $login;
1645
1646 # a .pst is a dead give-away for a valid player
1647 # if no pst file found, open and chekc for blocked users
1648 if (aio_stat "$path.pst") {
1041 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1649 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1042 aio_read $fh, 0, 512, my $buf, 0 or next; 1650 aio_read $fh, 0, 512, my $buf, 0 or next;
1043 $buf !~ /^password -------------$/m or next; # official not-valid tag 1651 $buf !~ /^password -------------$/m or next; # official not-valid tag
1652 }
1044 1653
1045 utf8::decode $login; 1654 utf8::decode $login;
1046 push @logins, $login; 1655 push @logins, $login;
1047 } 1656 }
1048 1657
… …
1056 1665
1057=cut 1666=cut
1058 1667
1059sub maps($) { 1668sub maps($) {
1060 my ($pl) = @_; 1669 my ($pl) = @_;
1670
1671 $pl = ref $pl ? $pl->ob->name : $pl;
1061 1672
1062 my $files = aio_readdir playerdir $pl 1673 my $files = aio_readdir playerdir $pl
1063 or return; 1674 or return;
1064 1675
1065 my @paths; 1676 my @paths;
… …
1067 for (@$files) { 1678 for (@$files) {
1068 utf8::decode $_; 1679 utf8::decode $_;
1069 next if /\.(?:pl|pst)$/; 1680 next if /\.(?:pl|pst)$/;
1070 next unless /^$PATH_SEP/o; 1681 next unless /^$PATH_SEP/o;
1071 1682
1072 s/\.map$//; 1683 push @paths, cf::map::normalise "~$pl/$_";
1073 push @paths, "~" . $pl->ob->name . "/" . $_;
1074 } 1684 }
1075 1685
1076 \@paths 1686 \@paths
1077} 1687}
1078 1688
1689=item $protocol_xml = $player->expand_cfpod ($cfpod)
1690
1691Expand deliantra pod fragments into protocol xml.
1692
1079=item $player->ext_reply ($msgid, $msgtype, %msg) 1693=item $player->ext_reply ($msgid, @msg)
1080 1694
1081Sends an ext reply to the player. 1695Sends an ext reply to the player.
1082 1696
1083=cut 1697=cut
1084 1698
1085sub ext_reply($$$%) { 1699sub ext_reply($$@) {
1086 my ($self, $id, %msg) = @_; 1700 my ($self, $id, @msg) = @_;
1087 1701
1088 $msg{msgid} = $id; 1702 $self->ns->ext_reply ($id, @msg)
1089
1090 $self->send ("ext " . cf::to_json \%msg);
1091} 1703}
1092 1704
1093package cf; 1705=item $player->ext_msg ($type, @msg)
1706
1707Sends an ext event to the client.
1708
1709=cut
1710
1711sub ext_msg($$@) {
1712 my ($self, $type, @msg) = @_;
1713
1714 $self->ns->ext_msg ($type, @msg);
1715}
1716
1717=head3 cf::region
1718
1719=over 4
1720
1721=cut
1722
1723package cf::region;
1724
1725=item cf::region::find_by_path $path
1726
1727Tries to decuce the likely region for a map knowing only its path.
1728
1729=cut
1730
1731sub find_by_path($) {
1732 my ($path) = @_;
1733
1734 my ($match, $specificity);
1735
1736 for my $region (list) {
1737 if ($region->{match} && $path =~ $region->{match}) {
1738 ($match, $specificity) = ($region, $region->specificity)
1739 if $region->specificity > $specificity;
1740 }
1741 }
1742
1743 $match
1744}
1094 1745
1095=back 1746=back
1096
1097 1747
1098=head3 cf::map 1748=head3 cf::map
1099 1749
1100=over 4 1750=over 4
1101 1751
… …
1105 1755
1106use Fcntl; 1756use Fcntl;
1107use Coro::AIO; 1757use Coro::AIO;
1108 1758
1109use overload 1759use overload
1110 '""' => \&as_string; 1760 '""' => \&as_string,
1761 fallback => 1;
1111 1762
1112our $MAX_RESET = 3600; 1763our $MAX_RESET = 3600;
1113our $DEFAULT_RESET = 3000; 1764our $DEFAULT_RESET = 3000;
1114 1765
1115sub generate_random_map { 1766sub generate_random_map {
1116 my ($self, $rmp) = @_; 1767 my ($self, $rmp) = @_;
1768
1769 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1117 1770
1118 # mit "rum" bekleckern, nicht 1771 # mit "rum" bekleckern, nicht
1119 $self->_create_random_map ( 1772 $self->_create_random_map (
1120 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1773 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1121 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1774 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
… …
1129 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1782 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1130 (cf::region::find $rmp->{region}), $rmp->{custom} 1783 (cf::region::find $rmp->{region}), $rmp->{custom}
1131 ) 1784 )
1132} 1785}
1133 1786
1787=item cf::map->register ($regex, $prio)
1788
1789Register a handler for the map path matching the given regex at the
1790givne priority (higher is better, built-in handlers have priority 0, the
1791default).
1792
1793=cut
1794
1134sub register { 1795sub register {
1135 my (undef, $regex) = @_; 1796 my (undef, $regex, $prio) = @_;
1136 my $pkg = caller; 1797 my $pkg = caller;
1137 1798
1138 no strict; 1799 no strict;
1139 push @{"$pkg\::ISA"}, __PACKAGE__; 1800 push @{"$pkg\::ISA"}, __PACKAGE__;
1140 1801
1141 $EXT_MAP{$pkg} = qr<$regex>; 1802 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1142} 1803}
1143 1804
1144# also paths starting with '/' 1805# also paths starting with '/'
1145$EXT_MAP{"cf::map"} = qr{^(?=/)}; 1806$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1807
1808sub thawer_merge {
1809 my ($self, $merge) = @_;
1810
1811 # we have to keep some variables in memory intact
1812 local $self->{path};
1813 local $self->{load_path};
1814
1815 $self->SUPER::thawer_merge ($merge);
1816}
1146 1817
1147sub normalise { 1818sub normalise {
1148 my ($path, $base) = @_; 1819 my ($path, $base) = @_;
1820
1821 $path = "$path"; # make sure its a string
1822
1823 $path =~ s/\.map$//;
1149 1824
1150 # map plan: 1825 # map plan:
1151 # 1826 #
1152 # /! non-realised random map exit (special hack!) 1827 # /! non-realised random map exit (special hack!)
1153 # {... are special paths that are not being touched 1828 # {... are special paths that are not being touched
… …
1181 1856
1182 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object 1857 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1183 1858
1184 $path = normalise $path, $base; 1859 $path = normalise $path, $base;
1185 1860
1186 for my $pkg (keys %EXT_MAP) { 1861 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1187 if ($path =~ $EXT_MAP{$pkg}) { 1862 if ($path =~ $EXT_MAP{$pkg}[1]) {
1188 my $self = bless cf::map::new, $pkg; 1863 my $self = bless cf::map::new, $pkg;
1189 $self->{path} = $path; $self->path ($path); 1864 $self->{path} = $path; $self->path ($path);
1190 $self->init; # pass $1 etc. 1865 $self->init; # pass $1 etc.
1191 return $self; 1866 return $self;
1192 } 1867 }
1193 } 1868 }
1194 1869
1195 Carp::carp "unable to resolve path '$path'."; 1870 Carp::cluck "unable to resolve path '$path' (base '$base').";
1196 () 1871 ()
1197} 1872}
1198 1873
1199sub init { 1874sub init {
1200 my ($self) = @_; 1875 my ($self) = @_;
… …
1215 1890
1216# the original (read-only) location 1891# the original (read-only) location
1217sub load_path { 1892sub load_path {
1218 my ($self) = @_; 1893 my ($self) = @_;
1219 1894
1220 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path} 1895 "$MAPDIR/$self->{path}.map"
1221} 1896}
1222 1897
1223# the temporary/swap location 1898# the temporary/swap location
1224sub save_path { 1899sub save_path {
1225 my ($self) = @_; 1900 my ($self) = @_;
1226 1901
1227 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1902 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1228 sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $path 1903 "$TMPDIR/$path.map"
1229} 1904}
1230 1905
1231# the unique path, undef == no special unique path 1906# the unique path, undef == no special unique path
1232sub uniq_path { 1907sub uniq_path {
1233 my ($self) = @_; 1908 my ($self) = @_;
1234 1909
1235 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1910 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1236 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1911 "$UNIQUEDIR/$path"
1237} 1912}
1238 1913
1239# and all this just because we cannot iterate over 1914sub decay_objects {
1240# all maps in C++...
1241sub change_all_map_light {
1242 my ($change) = @_; 1915 my ($self) = @_;
1243 1916
1244 $_->change_map_light ($change) 1917 return if $self->{deny_reset};
1245 for grep $_->outdoor, values %cf::MAP; 1918
1919 $self->do_decay_objects;
1246} 1920}
1247 1921
1248sub unlink_save { 1922sub unlink_save {
1249 my ($self) = @_; 1923 my ($self) = @_;
1250 1924
1251 utf8::encode (my $save = $self->save_path); 1925 utf8::encode (my $save = $self->save_path);
1252 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink $save; 1926 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1253 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink "$save.pst"; 1927 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1254} 1928}
1255 1929
1256sub load_header_from($) { 1930sub load_header_from($) {
1257 my ($self, $path) = @_; 1931 my ($self, $path) = @_;
1258 1932
1259 utf8::encode $path; 1933 utf8::encode $path;
1260 aio_open $path, O_RDONLY, 0 1934 my $f = new_from_file cf::object::thawer $path
1261 or return; 1935 or return;
1262 1936
1263 $self->_load_header ($path) 1937 $self->_load_header ($f)
1264 or return; 1938 or return;
1265 1939
1940 local $MAP_LOADING{$self->{path}} = $self;
1941 $f->resolve_delayed_derefs;
1942
1266 $self->{load_path} = $path; 1943 $self->{load_path} = $path;
1267 1944
1268 1 1945 1
1269} 1946}
1270 1947
1271sub load_orig { 1948sub load_header_orig {
1272 my ($self) = @_; 1949 my ($self) = @_;
1273 1950
1274 $self->load_header_from ($self->load_path) 1951 $self->load_header_from ($self->load_path)
1275} 1952}
1276 1953
1277sub load_temp { 1954sub load_header_temp {
1278 my ($self) = @_; 1955 my ($self) = @_;
1279 1956
1280 $self->load_header_from ($self->save_path) 1957 $self->load_header_from ($self->save_path)
1958}
1959
1960sub prepare_temp {
1961 my ($self) = @_;
1962
1963 $self->last_access ((delete $self->{last_access})
1964 || $cf::RUNTIME); #d#
1965 # safety
1966 $self->{instantiate_time} = $cf::RUNTIME
1967 if $self->{instantiate_time} > $cf::RUNTIME;
1968}
1969
1970sub prepare_orig {
1971 my ($self) = @_;
1972
1973 $self->{load_original} = 1;
1974 $self->{instantiate_time} = $cf::RUNTIME;
1975 $self->last_access ($cf::RUNTIME);
1976 $self->instantiate;
1281} 1977}
1282 1978
1283sub load_header { 1979sub load_header {
1284 my ($self) = @_; 1980 my ($self) = @_;
1285 1981
1286 if ($self->load_temp) { 1982 if ($self->load_header_temp) {
1287 $self->last_access ((delete $self->{last_access}) 1983 $self->prepare_temp;
1288 || $cf::RUNTIME); #d#
1289 # safety
1290 $self->{instantiate_time} = $cf::RUNTIME
1291 if $self->{instantiate_time} > $cf::RUNTIME;
1292 } else { 1984 } else {
1293 $self->load_orig 1985 $self->load_header_orig
1294 or return; 1986 or return;
1295 1987 $self->prepare_orig;
1296 $self->{load_original} = 1;
1297 $self->{instantiate_time} = $cf::RUNTIME;
1298 $self->last_access ($cf::RUNTIME);
1299 $self->instantiate;
1300 } 1988 }
1989
1990 $self->{deny_reset} = 1
1991 if $self->no_reset;
1992
1993 $self->default_region (cf::region::find_by_path $self->{path})
1994 unless $self->default_region;
1301 1995
1302 1 1996 1
1303} 1997}
1304 1998
1305sub find; 1999sub find;
1306sub find { 2000sub find {
1307 my ($path, $origin) = @_; 2001 my ($path, $origin) = @_;
1308 2002
1309 $path = normalise $path, $origin && $origin->path; 2003 $path = normalise $path, $origin && $origin->path;
1310 2004
2005 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1311 cf::lock_wait "map_find:$path"; 2006 my $guard2 = cf::lock_acquire "map_find:$path";
1312 2007
1313 $cf::MAP{$path} || do { 2008 $cf::MAP{$path} || do {
1314 my $guard = cf::lock_acquire "map_find:$path";
1315 my $map = new_from_path cf::map $path 2009 my $map = new_from_path cf::map $path
1316 or return; 2010 or return;
1317 2011
1318 $map->{last_save} = $cf::RUNTIME; 2012 $map->{last_save} = $cf::RUNTIME;
1319 2013
1320 $map->load_header 2014 $map->load_header
1321 or return; 2015 or return;
1322 2016
1323 if ($map->should_reset) { 2017 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
2018 # doing this can freeze the server in a sync job, obviously
2019 #$cf::WAIT_FOR_TICK->wait;
2020 undef $guard2;
2021 undef $guard1;
1324 $map->reset; 2022 $map->reset;
1325 undef $guard;
1326 $map = find $path 2023 return find $path;
1327 or return;
1328 } 2024 }
1329 2025
1330 $cf::MAP{$path} = $map 2026 $cf::MAP{$path} = $map
1331 } 2027 }
1332} 2028}
2029
2030sub pre_load { }
2031#sub post_load { } # XS
1333 2032
1334sub load { 2033sub load {
1335 my ($self) = @_; 2034 my ($self) = @_;
1336 2035
2036 local $self->{deny_reset} = 1; # loading can take a long time
2037
1337 my $path = $self->{path}; 2038 my $path = $self->{path};
2039
2040 {
1338 my $guard = cf::lock_acquire "map_load:$path"; 2041 my $guard = cf::lock_acquire "map_data:$path";
1339 2042
2043 return unless $self->valid;
1340 return if $self->in_memory != cf::MAP_SWAPPED; 2044 return unless $self->in_memory == cf::MAP_SWAPPED;
1341 2045
1342 $self->in_memory (cf::MAP_LOADING); 2046 $self->in_memory (cf::MAP_LOADING);
1343 2047
1344 $self->alloc; 2048 $self->alloc;
1345 $self->_load_objects ($self->{load_path}, 1) 2049
2050 $self->pre_load;
2051 cf::cede_to_tick;
2052
2053 my $f = new_from_file cf::object::thawer $self->{load_path};
2054 $f->skip_block;
2055 $self->_load_objects ($f)
1346 or return; 2056 or return;
1347 2057
1348 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2058 $self->post_load_original
1349 if delete $self->{load_original}; 2059 if delete $self->{load_original};
1350 2060
1351 if (my $uniq = $self->uniq_path) { 2061 if (my $uniq = $self->uniq_path) {
1352 utf8::encode $uniq; 2062 utf8::encode $uniq;
1353 if (aio_open $uniq, O_RDONLY, 0) { 2063 unless (aio_stat $uniq) {
2064 if (my $f = new_from_file cf::object::thawer $uniq) {
1354 $self->clear_unique_items; 2065 $self->clear_unique_items;
1355 $self->_load_objects ($uniq, 0); 2066 $self->_load_objects ($f);
2067 $f->resolve_delayed_derefs;
2068 }
1356 } 2069 }
1357 } 2070 }
1358 2071
1359 Coro::cede; 2072 $f->resolve_delayed_derefs;
1360 2073
2074 cf::cede_to_tick;
1361 # now do the right thing for maps 2075 # now do the right thing for maps
1362 $self->link_multipart_objects; 2076 $self->link_multipart_objects;
1363
1364 unless ($self->{deny_activate}) {
1365 $self->decay_objects;
1366 $self->fix_auto_apply;
1367 $self->update_buttons;
1368 Coro::cede;
1369 $self->set_darkness_map;
1370 $self->difficulty ($self->estimate_difficulty) 2077 $self->difficulty ($self->estimate_difficulty)
1371 unless $self->difficulty; 2078 unless $self->difficulty;
1372 Coro::cede; 2079 cf::cede_to_tick;
2080
2081 unless ($self->{deny_activate}) {
2082 $self->decay_objects;
2083 $self->fix_auto_apply;
2084 $self->update_buttons;
2085 cf::cede_to_tick;
1373 $self->activate; 2086 $self->activate;
1374 } 2087 }
1375 2088
2089 $self->{last_save} = $cf::RUNTIME;
2090 $self->last_access ($cf::RUNTIME);
2091
1376 $self->in_memory (cf::MAP_IN_MEMORY); 2092 $self->in_memory (cf::MAP_ACTIVE);
1377} 2093 }
1378 2094
2095 $self->post_load;
2096}
2097
2098# customize the map for a given player, i.e.
2099# return the _real_ map. used by e.g. per-player
2100# maps to change the path to ~playername/mappath
1379sub customise_for { 2101sub customise_for {
1380 my ($self, $ob) = @_; 2102 my ($self, $ob) = @_;
1381 2103
1382 return find "~" . $ob->name . "/" . $self->{path} 2104 return find "~" . $ob->name . "/" . $self->{path}
1383 if $self->per_player; 2105 if $self->per_player;
1384 2106
2107# return find "?party/" . $ob->name . "/" . $self->{path}
2108# if $self->per_party;
2109
1385 $self 2110 $self
1386} 2111}
1387 2112
1388# find and load all maps in the 3x3 area around a map 2113# find and load all maps in the 3x3 area around a map
1389sub load_diag { 2114sub load_neighbours {
1390 my ($map) = @_; 2115 my ($map) = @_;
1391 2116
1392 my @diag; # diagonal neighbours 2117 my @neigh; # diagonal neighbours
1393 2118
1394 for (0 .. 3) { 2119 for (0 .. 3) {
1395 my $neigh = $map->tile_path ($_) 2120 my $neigh = $map->tile_path ($_)
1396 or next; 2121 or next;
1397 $neigh = find $neigh, $map 2122 $neigh = find $neigh, $map
1398 or next; 2123 or next;
1399 $neigh->load; 2124 $neigh->load;
1400 2125
2126 push @neigh,
1401 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2127 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1402 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2128 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1403 } 2129 }
1404 2130
1405 for (@diag) { 2131 for (grep defined $_->[0], @neigh) {
2132 my ($path, $origin) = @$_;
1406 my $neigh = find @$_ 2133 my $neigh = find $path, $origin
1407 or next; 2134 or next;
1408 $neigh->load; 2135 $neigh->load;
1409 } 2136 }
1410} 2137}
1411 2138
… …
1416} 2143}
1417 2144
1418sub do_load_sync { 2145sub do_load_sync {
1419 my ($map) = @_; 2146 my ($map) = @_;
1420 2147
2148 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2149 if $Coro::current == $Coro::main;
2150
1421 cf::sync_job { $map->load }; 2151 cf::sync_job { $map->load };
1422} 2152}
1423 2153
1424our %MAP_PREFETCH; 2154our %MAP_PREFETCH;
1425our $MAP_PREFETCHER = Coro::async { 2155our $MAP_PREFETCHER = undef;
1426 while () {
1427 for my $path (keys %MAP_PREFETCH) {
1428 my $map = find $path
1429 or next;
1430 $map->load;
1431
1432 delete $MAP_PREFETCH{$path};
1433 }
1434 Coro::schedule;
1435 }
1436};
1437 2156
1438sub find_async { 2157sub find_async {
1439 my ($path, $origin) = @_; 2158 my ($path, $origin, $load) = @_;
1440 2159
1441 $path = normalise $path, $origin && $origin->{path}; 2160 $path = normalise $path, $origin && $origin->{path};
1442 2161
1443 if (my $map = $cf::MAP{$path}) { 2162 if (my $map = $cf::MAP{$path}) {
1444 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2163 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2164 }
2165
2166 $MAP_PREFETCH{$path} |= $load;
2167
2168 $MAP_PREFETCHER ||= cf::async {
2169 $Coro::current->{desc} = "map prefetcher";
2170
2171 while (%MAP_PREFETCH) {
2172 while (my ($k, $v) = each %MAP_PREFETCH) {
2173 if (my $map = find $k) {
2174 $map->load if $v;
2175 }
2176
2177 delete $MAP_PREFETCH{$k};
2178 }
2179 }
2180 undef $MAP_PREFETCHER;
1445 } 2181 };
1446
1447 $MAP_PREFETCH{$path} = 0;
1448 $MAP_PREFETCHER->ready; 2182 $MAP_PREFETCHER->prio (6);
1449 2183
1450 () 2184 ()
1451} 2185}
1452 2186
1453sub save { 2187sub save {
1454 my ($self) = @_; 2188 my ($self) = @_;
1455 2189
1456 my $lock = cf::lock_acquire "map_data:" . $self->path; 2190 my $lock = cf::lock_acquire "map_data:$self->{path}";
1457 2191
1458 $self->{last_save} = $cf::RUNTIME; 2192 $self->{last_save} = $cf::RUNTIME;
1459 2193
1460 return unless $self->dirty; 2194 return unless $self->dirty;
1461 2195
… …
1467 return if $self->{deny_save}; 2201 return if $self->{deny_save};
1468 2202
1469 local $self->{last_access} = $self->last_access;#d# 2203 local $self->{last_access} = $self->last_access;#d#
1470 2204
1471 cf::async { 2205 cf::async {
2206 $Coro::current->{desc} = "map player save";
1472 $_->contr->save for $self->players; 2207 $_->contr->save for $self->players;
1473 }; 2208 };
2209
2210 cf::get_slot 0.02;
1474 2211
1475 if ($uniq) { 2212 if ($uniq) {
1476 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2213 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1477 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2214 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1478 } else { 2215 } else {
… …
1484 my ($self) = @_; 2221 my ($self) = @_;
1485 2222
1486 # save first because save cedes 2223 # save first because save cedes
1487 $self->save; 2224 $self->save;
1488 2225
1489 my $lock = cf::lock_acquire "map_data:" . $self->path; 2226 my $lock = cf::lock_acquire "map_data:$self->{path}";
1490 2227
1491 return if $self->players; 2228 return if $self->players;
1492 return if $self->in_memory != cf::MAP_IN_MEMORY; 2229 return if $self->in_memory != cf::MAP_ACTIVE;
1493 return if $self->{deny_save}; 2230 return if $self->{deny_save};
1494 2231
2232 $self->in_memory (cf::MAP_SWAPPED);
2233
2234 $self->deactivate;
2235 $_->clear_links_to ($self) for values %cf::MAP;
1495 $self->clear; 2236 $self->clear;
1496 $self->in_memory (cf::MAP_SWAPPED);
1497} 2237}
1498 2238
1499sub reset_at { 2239sub reset_at {
1500 my ($self) = @_; 2240 my ($self) = @_;
1501 2241
1502 # TODO: safety, remove and allow resettable per-player maps 2242 # TODO: safety, remove and allow resettable per-player maps
1503 return 1e99 if $self->isa ("ext::map_per_player");
1504 return 1e99 if $self->{deny_reset}; 2243 return 1e99 if $self->{deny_reset};
1505 2244
1506 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2245 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1507 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2246 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1508 2247
… …
1513 my ($self) = @_; 2252 my ($self) = @_;
1514 2253
1515 $self->reset_at <= $cf::RUNTIME 2254 $self->reset_at <= $cf::RUNTIME
1516} 2255}
1517 2256
1518sub rename {
1519 my ($self, $new_path) = @_;
1520
1521 normalise $new_path;
1522
1523 $self->unlink_save;
1524
1525 delete $cf::MAP{$self->path};
1526 $self->{path} = $new_path; $self->path ($self->{path});
1527 $cf::MAP{$self->path} = $self;
1528
1529 $self->save;
1530}
1531
1532sub reset { 2257sub reset {
1533 my ($self) = @_; 2258 my ($self) = @_;
1534 2259
1535 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2260 my $lock = cf::lock_acquire "map_data:$self->{path}";
1536 2261
1537 return if $self->players; 2262 return if $self->players;
1538 return if $self->isa ("ext::map_per_player");#d#
1539 2263
1540 warn "resetting map ", $self->path;#d# 2264 warn "resetting map ", $self->path, "\n";
2265
2266 $self->in_memory (cf::MAP_SWAPPED);
2267
2268 # need to save uniques path
2269 unless ($self->{deny_save}) {
2270 my $uniq = $self->uniq_path; utf8::encode $uniq;
2271
2272 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2273 if $uniq;
2274 }
1541 2275
1542 delete $cf::MAP{$self->path}; 2276 delete $cf::MAP{$self->path};
1543 2277
1544 $self->in_memory (cf::MAP_SWAPPED); 2278 $self->deactivate;
2279 $_->clear_links_to ($self) for values %cf::MAP;
1545 $self->clear; 2280 $self->clear;
1546
1547 $_->clear_links_to ($self) for values %cf::MAP;
1548 2281
1549 $self->unlink_save; 2282 $self->unlink_save;
1550 $self->destroy; 2283 $self->destroy;
1551} 2284}
1552 2285
1553my $nuke_counter = "aaaa"; 2286my $nuke_counter = "aaaa";
1554 2287
1555sub nuke { 2288sub nuke {
1556 my ($self) = @_; 2289 my ($self) = @_;
1557 2290
2291 {
2292 my $lock = cf::lock_acquire "map_data:$self->{path}";
2293
2294 delete $cf::MAP{$self->path};
2295
2296 $self->unlink_save;
2297
2298 bless $self, "cf::map";
2299 delete $self->{deny_reset};
1558 $self->{deny_save} = 1; 2300 $self->{deny_save} = 1;
1559 $self->reset_timeout (1); 2301 $self->reset_timeout (1);
1560 $self->rename ("{nuke}/" . ($nuke_counter++)); 2302 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2303
2304 $cf::MAP{$self->path} = $self;
2305 }
2306
1561 $self->reset; # polite request, might not happen 2307 $self->reset; # polite request, might not happen
2308}
2309
2310=item $maps = cf::map::tmp_maps
2311
2312Returns an arrayref with all map paths of currently instantiated and saved
2313maps. May block.
2314
2315=cut
2316
2317sub tmp_maps() {
2318 [
2319 map {
2320 utf8::decode $_;
2321 /\.map$/
2322 ? normalise $_
2323 : ()
2324 } @{ aio_readdir $TMPDIR or [] }
2325 ]
2326}
2327
2328=item $maps = cf::map::random_maps
2329
2330Returns an arrayref with all map paths of currently instantiated and saved
2331random maps. May block.
2332
2333=cut
2334
2335sub random_maps() {
2336 [
2337 map {
2338 utf8::decode $_;
2339 /\.map$/
2340 ? normalise "?random/$_"
2341 : ()
2342 } @{ aio_readdir $RANDOMDIR or [] }
2343 ]
1562} 2344}
1563 2345
1564=item cf::map::unique_maps 2346=item cf::map::unique_maps
1565 2347
1566Returns an arrayref of paths of all shared maps that have 2348Returns an arrayref of paths of all shared maps that have
1567instantiated unique items. May block. 2349instantiated unique items. May block.
1568 2350
1569=cut 2351=cut
1570 2352
1571sub unique_maps() { 2353sub unique_maps() {
1572 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2354 [
1573 or return; 2355 map {
1574
1575 my @paths;
1576
1577 for (@$files) {
1578 utf8::decode $_; 2356 utf8::decode $_;
1579 next if /\.pst$/; 2357 s/\.map$//; # TODO future compatibility hack
1580 next unless /^$PATH_SEP/o; 2358 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2359 ? ()
2360 : normalise $_
2361 } @{ aio_readdir $UNIQUEDIR or [] }
2362 ]
2363}
1581 2364
2365=item cf::map::static_maps
2366
2367Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2368file in the shared directory excluding F</styles> and F</editor>). May
2369block.
2370
2371=cut
2372
2373sub static_maps() {
2374 my @dirs = "";
2375 my @maps;
2376
2377 while (@dirs) {
2378 my $dir = shift @dirs;
2379
2380 next if $dir eq "/styles" || $dir eq "/editor";
2381
2382 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2383 or return;
2384
2385 for (@$files) {
1582 s/\.map$//; 2386 s/\.map$// or next;
1583 push @paths, $_; 2387 utf8::decode $_;
1584 } 2388 push @maps, "$dir/$_";
2389 }
1585 2390
1586 \@paths 2391 push @dirs, map "$dir/$_", @$dirs;
1587} 2392 }
1588 2393
1589package cf; 2394 \@maps
2395}
1590 2396
1591=back 2397=back
1592 2398
1593=head3 cf::object 2399=head3 cf::object
1594 2400
… …
1598 2404
1599=over 4 2405=over 4
1600 2406
1601=item $ob->inv_recursive 2407=item $ob->inv_recursive
1602 2408
1603Returns the inventory of the object _and_ their inventories, recursively. 2409Returns the inventory of the object I<and> their inventories, recursively,
2410but I<not> the object itself.
1604 2411
1605=cut 2412=cut
1606 2413
1607sub inv_recursive_; 2414sub inv_recursive_;
1608sub inv_recursive_ { 2415sub inv_recursive_ {
… …
1611 2418
1612sub inv_recursive { 2419sub inv_recursive {
1613 inv_recursive_ inv $_[0] 2420 inv_recursive_ inv $_[0]
1614} 2421}
1615 2422
2423=item $ref = $ob->ref
2424
2425Creates and returns a persistent reference to an object that can be stored as a string.
2426
2427=item $ob = cf::object::deref ($refstring)
2428
2429returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2430even if the object actually exists. May block.
2431
2432=cut
2433
2434sub deref {
2435 my ($ref) = @_;
2436
2437 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2438 my ($uuid, $name) = ($1, $2);
2439 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2440 or return;
2441 $pl->ob->uuid eq $uuid
2442 or return;
2443
2444 $pl->ob
2445 } else {
2446 warn "$ref: cannot resolve object reference\n";
2447 undef
2448 }
2449}
2450
1616package cf; 2451package cf;
1617 2452
1618=back 2453=back
1619 2454
1620=head3 cf::object::player 2455=head3 cf::object::player
… …
1626Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2461Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
1627can be C<undef>. Does the right thing when the player is currently in a 2462can be C<undef>. Does the right thing when the player is currently in a
1628dialogue with the given NPC character. 2463dialogue with the given NPC character.
1629 2464
1630=cut 2465=cut
2466
2467our $SAY_CHANNEL = {
2468 id => "say",
2469 title => "Map",
2470 reply => "say ",
2471 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2472};
2473
2474our $CHAT_CHANNEL = {
2475 id => "chat",
2476 title => "Chat",
2477 reply => "chat ",
2478 tooltip => "Player chat and shouts, global to the server.",
2479};
1631 2480
1632# rough implementation of a future "reply" method that works 2481# rough implementation of a future "reply" method that works
1633# with dialog boxes. 2482# with dialog boxes.
1634#TODO: the first argument must go, split into a $npc->reply_to ( method 2483#TODO: the first argument must go, split into a $npc->reply_to ( method
1635sub cf::object::player::reply($$$;$) { 2484sub cf::object::player::reply($$$;$) {
… …
1637 2486
1638 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2487 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1639 2488
1640 if ($self->{record_replies}) { 2489 if ($self->{record_replies}) {
1641 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2490 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2491
1642 } else { 2492 } else {
2493 my $pl = $self->contr;
2494
2495 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2496 my $dialog = $pl->{npc_dialog};
2497 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2498
2499 } else {
1643 $msg = $npc->name . " says: $msg" if $npc; 2500 $msg = $npc->name . " says: $msg" if $npc;
1644 $self->message ($msg, $flags); 2501 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2502 }
1645 } 2503 }
2504}
2505
2506=item $object->send_msg ($channel, $msg, $color, [extra...])
2507
2508=cut
2509
2510sub cf::object::send_msg {
2511 my $pl = shift->contr
2512 or return;
2513 $pl->send_msg (@_);
1646} 2514}
1647 2515
1648=item $player_object->may ("access") 2516=item $player_object->may ("access")
1649 2517
1650Returns wether the given player is authorized to access resource "access" 2518Returns wether the given player is authorized to access resource "access"
… …
1663 2531
1664=item $player_object->enter_link 2532=item $player_object->enter_link
1665 2533
1666Freezes the player and moves him/her to a special map (C<{link}>). 2534Freezes the player and moves him/her to a special map (C<{link}>).
1667 2535
1668The player should be reasonably safe there for short amounts of time. You 2536The player should be reasonably safe there for short amounts of time (e.g.
1669I<MUST> call C<leave_link> as soon as possible, though. 2537for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2538though, as the palyer cannot control the character while it is on the link
2539map.
1670 2540
1671Will never block. 2541Will never block.
1672 2542
1673=item $player_object->leave_link ($map, $x, $y) 2543=item $player_object->leave_link ($map, $x, $y)
1674 2544
… …
1682=cut 2552=cut
1683 2553
1684sub link_map { 2554sub link_map {
1685 unless ($LINK_MAP) { 2555 unless ($LINK_MAP) {
1686 $LINK_MAP = cf::map::find "{link}" 2556 $LINK_MAP = cf::map::find "{link}"
1687 or do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 }; 2557 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1688 $LINK_MAP->load; 2558 $LINK_MAP->load;
1689 } 2559 }
1690 2560
1691 $LINK_MAP 2561 $LINK_MAP
1692} 2562}
… …
1697 $self->deactivate_recursive; 2567 $self->deactivate_recursive;
1698 2568
1699 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2569 return if UNIVERSAL::isa $self->map, "ext::map_link";
1700 2570
1701 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2571 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1702 if $self->map; 2572 if $self->map && $self->map->{path} ne "{link}";
1703 2573
1704 $self->enter_map ($LINK_MAP || link_map, 20, 20); 2574 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1705} 2575}
1706 2576
1707sub cf::object::player::leave_link { 2577sub cf::object::player::leave_link {
1708 my ($self, $map, $x, $y) = @_; 2578 my ($self, $map, $x, $y) = @_;
2579
2580 return unless $self->contr->active;
1709 2581
1710 my $link_pos = delete $self->{_link_pos}; 2582 my $link_pos = delete $self->{_link_pos};
1711 2583
1712 unless ($map) { 2584 unless ($map) {
1713 # restore original map position 2585 # restore original map position
… …
1724 ($x, $y) = (-1, -1) 2596 ($x, $y) = (-1, -1)
1725 unless (defined $x) && (defined $y); 2597 unless (defined $x) && (defined $y);
1726 2598
1727 # use -1 or undef as default coordinates, not 0, 0 2599 # use -1 or undef as default coordinates, not 0, 0
1728 ($x, $y) = ($map->enter_x, $map->enter_y) 2600 ($x, $y) = ($map->enter_x, $map->enter_y)
1729 if $x <=0 && $y <= 0; 2601 if $x <= 0 && $y <= 0;
1730 2602
1731 $map->load; 2603 $map->load;
1732 $map->load_diag; 2604 $map->load_neighbours;
1733 2605
1734 return unless $self->contr->active; 2606 return unless $self->contr->active;
2607
2608 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2609 $self->enter_map ($map, $x, $y);
2610
2611 # only activate afterwards, to support waiting in hooks
1735 $self->activate_recursive; 2612 $self->activate_recursive;
1736 $self->enter_map ($map, $x, $y);
1737} 2613}
1738 2614
1739cf::player->attach ( 2615=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1740 on_logout => sub {
1741 my ($pl) = @_;
1742 2616
1743 # abort map switching before logout 2617Moves the player to the given map-path and coordinates by first freezing
1744 if ($pl->ob->{_link_pos}) { 2618her, loading and preparing them map, calling the provided $check callback
1745 cf::sync_job { 2619that has to return the map if sucecssful, and then unfreezes the player on
1746 $pl->ob->leave_link 2620the new (success) or old (failed) map position. In either case, $done will
1747 }; 2621be called at the end of this process.
1748 }
1749 },
1750 on_login => sub {
1751 my ($pl) = @_;
1752 2622
1753 # try to abort aborted map switching on player login :) 2623Note that $check will be called with a potentially non-loaded map, so if
1754 # should happen only on crashes 2624it needs a loaded map it has to call C<< ->load >>.
1755 if ($pl->ob->{_link_pos}) {
1756 $pl->ob->enter_link;
1757 (async {
1758 # we need this sleep as the login has a concurrent enter_exit running
1759 # and this sleep increases chances of the player not ending up in scorn
1760 $pl->ob->reply (undef,
1761 "There was an internal problem at your last logout, "
1762 . "the server will try to bring you to your intended destination in a second.",
1763 cf::NDI_RED);
1764 Coro::Timer::sleep 1;
1765 $pl->ob->leave_link;
1766 })->prio (2);
1767 }
1768 },
1769);
1770 2625
1771=item $player_object->goto ($path, $x, $y)
1772
1773=cut 2626=cut
2627
2628our $GOTOGEN;
1774 2629
1775sub cf::object::player::goto { 2630sub cf::object::player::goto {
1776 my ($self, $path, $x, $y) = @_; 2631 my ($self, $path, $x, $y, $check, $done) = @_;
2632
2633 # do generation counting so two concurrent goto's will be executed in-order
2634 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1777 2635
1778 $self->enter_link; 2636 $self->enter_link;
1779 2637
1780 (async { 2638 (async {
1781 my $map = cf::map::find $path; 2639 $Coro::current->{desc} = "player::goto $path $x $y";
2640
2641 # *tag paths override both path and x|y
2642 if ($path =~ /^\*(.*)$/) {
2643 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2644 my $ob = $obs[rand @obs];
2645
2646 # see if we actually can go there
2647 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2648 $ob = $obs[rand @obs];
2649 } else {
2650 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2651 }
2652 # else put us there anyways for now #d#
2653
2654 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2655 } else {
2656 ($path, $x, $y) = (undef, undef, undef);
2657 }
2658 }
2659
2660 my $map = eval {
2661 my $map = defined $path ? cf::map::find $path : undef;
2662
2663 if ($map) {
1782 $map = $map->customise_for ($self) if $map; 2664 $map = $map->customise_for ($self);
1783 2665 $map = $check->($map) if $check && $map;
1784# warn "entering ", $map->path, " at ($x, $y)\n" 2666 } else {
1785# if $map;
1786
1787 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2667 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2668 }
1788 2669
2670 $map
2671 };
2672
2673 if ($@) {
2674 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2675 LOG llevError | logBacktrace, Carp::longmess $@;
2676 }
2677
2678 if ($gen == $self->{_goto_generation}) {
2679 delete $self->{_goto_generation};
1789 $self->leave_link ($map, $x, $y); 2680 $self->leave_link ($map, $x, $y);
2681 }
2682
2683 $done->() if $done;
1790 })->prio (1); 2684 })->prio (1);
1791} 2685}
1792 2686
1793=item $player_object->enter_exit ($exit_object) 2687=item $player_object->enter_exit ($exit_object)
1794 2688
… …
1796 2690
1797sub parse_random_map_params { 2691sub parse_random_map_params {
1798 my ($spec) = @_; 2692 my ($spec) = @_;
1799 2693
1800 my $rmp = { # defaults 2694 my $rmp = { # defaults
1801 xsize => 10, 2695 xsize => (cf::rndm 15, 40),
1802 ysize => 10, 2696 ysize => (cf::rndm 15, 40),
2697 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2698 #layout => string,
1803 }; 2699 };
1804 2700
1805 for (split /\n/, $spec) { 2701 for (split /\n/, $spec) {
1806 my ($k, $v) = split /\s+/, $_, 2; 2702 my ($k, $v) = split /\s+/, $_, 2;
1807 2703
… …
1819 # that depends on the exit object 2715 # that depends on the exit object
1820 2716
1821 my $rmp = parse_random_map_params $exit->msg; 2717 my $rmp = parse_random_map_params $exit->msg;
1822 2718
1823 if ($exit->map) { 2719 if ($exit->map) {
1824 $rmp->{region} = $exit->map->region_name; 2720 $rmp->{region} = $exit->region->name;
1825 $rmp->{origin_map} = $exit->map->path; 2721 $rmp->{origin_map} = $exit->map->path;
1826 $rmp->{origin_x} = $exit->x; 2722 $rmp->{origin_x} = $exit->x;
1827 $rmp->{origin_y} = $exit->y; 2723 $rmp->{origin_y} = $exit->y;
2724
2725 $exit->map->touch;
1828 } 2726 }
1829 2727
1830 $rmp->{random_seed} ||= $exit->random_seed; 2728 $rmp->{random_seed} ||= $exit->random_seed;
1831 2729
1832 my $data = cf::to_json $rmp; 2730 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
1833 my $md5 = Digest::MD5::md5_hex $data; 2731 my $md5 = Digest::MD5::md5_hex $data;
2732 my $meta = "$RANDOMDIR/$md5.meta";
1834 2733
1835 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) { 2734 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1836 aio_write $fh, 0, (length $data), $data, 0; 2735 aio_write $fh, 0, (length $data), $data, 0;
2736 undef $fh;
2737 aio_rename "$meta~", $meta;
1837 2738
2739 my $slaying = "?random/$md5";
2740
2741 if ($exit->valid) {
1838 $exit->slaying ("?random/$md5"); 2742 $exit->slaying ("?random/$md5");
1839 $exit->msg (undef); 2743 $exit->msg (undef);
2744 }
1840 } 2745 }
1841} 2746}
1842 2747
1843sub cf::object::player::enter_exit { 2748sub cf::object::player::enter_exit {
1844 my ($self, $exit) = @_; 2749 my ($self, $exit) = @_;
… …
1846 return unless $self->type == cf::PLAYER; 2751 return unless $self->type == cf::PLAYER;
1847 2752
1848 $self->enter_link; 2753 $self->enter_link;
1849 2754
1850 (async { 2755 (async {
1851 $self->deactivate_recursive; # just to be sure 2756 $Coro::current->{desc} = "enter_exit";
2757
1852 unless (eval { 2758 unless (eval {
2759 $self->deactivate_recursive; # just to be sure
2760
2761 # random map handling
2762 {
2763 my $guard = cf::lock_acquire "exit_prepare:$exit";
2764
1853 prepare_random_map $exit 2765 prepare_random_map $exit
1854 if $exit->slaying eq "/!"; 2766 if $exit->slaying eq "/!";
2767 }
1855 2768
1856 my $path = new_from_path cf::map $exit->slaying, $exit->map && $exit->map->path; 2769 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1857 $self->goto ($path, $exit->stats->hp, $exit->stats->sp); 2770 my $x = $exit->stats->hp;
2771 my $y = $exit->stats->sp;
1858 2772
2773 $self->goto ($map, $x, $y);
2774
2775 # if exit is damned, update players death & WoR home-position
2776 $self->contr->savebed ($map, $x, $y)
2777 if $exit->flag (cf::FLAG_DAMNED);
2778
1859 1; 2779 1
1860 }) { 2780 }) {
1861 $self->message ("Something went wrong deep within the crossfire server. " 2781 $self->message ("Something went wrong deep within the deliantra server. "
1862 . "I'll try to bring you back to the map you were before. " 2782 . "I'll try to bring you back to the map you were before. "
1863 . "Please report this to the dungeon master!", 2783 . "Please report this to the dungeon master!",
1864 cf::NDI_UNIQUE | cf::NDI_RED); 2784 cf::NDI_UNIQUE | cf::NDI_RED);
1865 2785
1866 warn "ERROR in enter_exit: $@"; 2786 warn "ERROR in enter_exit: $@";
1867 $self->leave_link; 2787 $self->leave_link;
1868 } 2788 }
1869 })->prio (1); 2789 })->prio (1);
… …
1882 2802
1883sub cf::client::send_drawinfo { 2803sub cf::client::send_drawinfo {
1884 my ($self, $text, $flags) = @_; 2804 my ($self, $text, $flags) = @_;
1885 2805
1886 utf8::encode $text; 2806 utf8::encode $text;
1887 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2807 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1888} 2808}
1889 2809
2810=item $client->send_big_packet ($pkt)
2811
2812Like C<send_packet>, but tries to compress large packets, and fragments
2813them as required.
2814
2815=cut
2816
2817our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2818
2819sub cf::client::send_big_packet {
2820 my ($self, $pkt) = @_;
2821
2822 # try lzf for large packets
2823 $pkt = "lzf " . Compress::LZF::compress $pkt
2824 if 1024 <= length $pkt and $self->{can_lzf};
2825
2826 # split very large packets
2827 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2828 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2829 $pkt = "frag";
2830 }
2831
2832 $self->send_packet ($pkt);
2833}
2834
2835=item $client->send_msg ($channel, $msg, $color, [extra...])
2836
2837Send a drawinfo or msg packet to the client, formatting the msg for the
2838client if neccessary. C<$type> should be a string identifying the type of
2839the message, with C<log> being the default. If C<$color> is negative, suppress
2840the message unless the client supports the msg packet.
2841
2842=cut
2843
2844# non-persistent channels (usually the info channel)
2845our %CHANNEL = (
2846 "c/motd" => {
2847 id => "infobox",
2848 title => "MOTD",
2849 reply => undef,
2850 tooltip => "The message of the day",
2851 },
2852 "c/identify" => {
2853 id => "infobox",
2854 title => "Identify",
2855 reply => undef,
2856 tooltip => "Items recently identified",
2857 },
2858 "c/examine" => {
2859 id => "infobox",
2860 title => "Examine",
2861 reply => undef,
2862 tooltip => "Signs and other items you examined",
2863 },
2864 "c/shopinfo" => {
2865 id => "infobox",
2866 title => "Shop Info",
2867 reply => undef,
2868 tooltip => "What your bargaining skill tells you about the shop",
2869 },
2870 "c/book" => {
2871 id => "infobox",
2872 title => "Book",
2873 reply => undef,
2874 tooltip => "The contents of a note or book",
2875 },
2876 "c/lookat" => {
2877 id => "infobox",
2878 title => "Look",
2879 reply => undef,
2880 tooltip => "What you saw there",
2881 },
2882 "c/who" => {
2883 id => "infobox",
2884 title => "Players",
2885 reply => undef,
2886 tooltip => "Shows players who are currently online",
2887 },
2888 "c/body" => {
2889 id => "infobox",
2890 title => "Body Parts",
2891 reply => undef,
2892 tooltip => "Shows which body parts you posess and are available",
2893 },
2894 "c/statistics" => {
2895 id => "infobox",
2896 title => "Statistics",
2897 reply => undef,
2898 tooltip => "Shows your primary statistics",
2899 },
2900 "c/skills" => {
2901 id => "infobox",
2902 title => "Skills",
2903 reply => undef,
2904 tooltip => "Shows your experience per skill and item power",
2905 },
2906 "c/shopitems" => {
2907 id => "infobox",
2908 title => "Shop Items",
2909 reply => undef,
2910 tooltip => "Shows the items currently for sale in this shop",
2911 },
2912 "c/resistances" => {
2913 id => "infobox",
2914 title => "Resistances",
2915 reply => undef,
2916 tooltip => "Shows your resistances",
2917 },
2918 "c/pets" => {
2919 id => "infobox",
2920 title => "Pets",
2921 reply => undef,
2922 tooltip => "Shows information abotu your pets/a specific pet",
2923 },
2924 "c/perceiveself" => {
2925 id => "infobox",
2926 title => "Perceive Self",
2927 reply => undef,
2928 tooltip => "You gained detailed knowledge about yourself",
2929 },
2930 "c/uptime" => {
2931 id => "infobox",
2932 title => "Uptime",
2933 reply => undef,
2934 tooltip => "How long the server has been running since last restart",
2935 },
2936 "c/mapinfo" => {
2937 id => "infobox",
2938 title => "Map Info",
2939 reply => undef,
2940 tooltip => "Information related to the maps",
2941 },
2942 "c/party" => {
2943 id => "party",
2944 title => "Party",
2945 reply => "gsay ",
2946 tooltip => "Messages and chat related to your party",
2947 },
2948 "c/death" => {
2949 id => "death",
2950 title => "Death",
2951 reply => undef,
2952 tooltip => "Reason for and more info about your most recent death",
2953 },
2954 "c/say" => $SAY_CHANNEL,
2955 "c/chat" => $CHAT_CHANNEL,
2956);
2957
2958sub cf::client::send_msg {
2959 my ($self, $channel, $msg, $color, @extra) = @_;
2960
2961 $msg = $self->pl->expand_cfpod ($msg)
2962 unless $color & cf::NDI_VERBATIM;
2963
2964 $color &= cf::NDI_CLIENT_MASK; # just in case...
2965
2966 # check predefined channels, for the benefit of C
2967 if ($CHANNEL{$channel}) {
2968 $channel = $CHANNEL{$channel};
2969
2970 $self->ext_msg (channel_info => $channel);
2971 $channel = $channel->{id};
2972
2973 } elsif (ref $channel) {
2974 # send meta info to client, if not yet sent
2975 unless (exists $self->{channel}{$channel->{id}}) {
2976 $self->{channel}{$channel->{id}} = $channel;
2977 $self->ext_msg (channel_info => $channel);
2978 }
2979
2980 $channel = $channel->{id};
2981 }
2982
2983 return unless @extra || length $msg;
2984
2985 # default colour, mask it out
2986 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2987 if $color & cf::NDI_DEF;
2988
2989 my $pkt = "msg "
2990 . $self->{json_coder}->encode (
2991 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2992 );
2993
2994 $self->send_big_packet ($pkt);
2995}
2996
2997=item $client->ext_msg ($type, @msg)
2998
2999Sends an ext event to the client.
3000
3001=cut
3002
3003sub cf::client::ext_msg($$@) {
3004 my ($self, $type, @msg) = @_;
3005
3006 if ($self->extcmd == 2) {
3007 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3008 } elsif ($self->extcmd == 1) { # TODO: remove
3009 push @msg, msgtype => "event_$type";
3010 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3011 }
3012}
3013
3014=item $client->ext_reply ($msgid, @msg)
3015
3016Sends an ext reply to the client.
3017
3018=cut
3019
3020sub cf::client::ext_reply($$@) {
3021 my ($self, $id, @msg) = @_;
3022
3023 if ($self->extcmd == 2) {
3024 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3025 } elsif ($self->extcmd == 1) {
3026 #TODO: version 1, remove
3027 unshift @msg, msgtype => "reply", msgid => $id;
3028 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3029 }
3030}
1890 3031
1891=item $success = $client->query ($flags, "text", \&cb) 3032=item $success = $client->query ($flags, "text", \&cb)
1892 3033
1893Queues a query to the client, calling the given callback with 3034Queues a query to the client, calling the given callback with
1894the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 3035the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1895C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 3036C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1896 3037
1897Queries can fail, so check the return code. Or don't, as queries will become 3038Queries can fail, so check the return code. Or don't, as queries will
1898reliable at some point in the future. 3039become reliable at some point in the future.
1899 3040
1900=cut 3041=cut
1901 3042
1902sub cf::client::query { 3043sub cf::client::query {
1903 my ($self, $flags, $text, $cb) = @_; 3044 my ($self, $flags, $text, $cb) = @_;
… …
1911 utf8::encode $text; 3052 utf8::encode $text;
1912 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 3053 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1913 3054
1914 $self->send_packet ($self->{query_queue}[0][0]) 3055 $self->send_packet ($self->{query_queue}[0][0])
1915 if @{ $self->{query_queue} } == 1; 3056 if @{ $self->{query_queue} } == 1;
3057
3058 1
1916} 3059}
1917 3060
1918cf::client->attach ( 3061cf::client->attach (
3062 on_connect => sub {
3063 my ($ns) = @_;
3064
3065 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
3066 },
1919 on_reply => sub { 3067 on_reply => sub {
1920 my ($ns, $msg) = @_; 3068 my ($ns, $msg) = @_;
1921 3069
1922 # this weird shuffling is so that direct followup queries 3070 # this weird shuffling is so that direct followup queries
1923 # get handled first 3071 # get handled first
1924 my $queue = delete $ns->{query_queue} 3072 my $queue = delete $ns->{query_queue}
1925 or return; # be conservative, not sure how that can happen, but we saw a crash here 3073 or return; # be conservative, not sure how that can happen, but we saw a crash here
1926 3074
1927 (shift @$queue)->[1]->($msg); 3075 (shift @$queue)->[1]->($msg);
3076 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1928 3077
1929 push @{ $ns->{query_queue} }, @$queue; 3078 push @{ $ns->{query_queue} }, @$queue;
1930 3079
1931 if (@{ $ns->{query_queue} } == @$queue) { 3080 if (@{ $ns->{query_queue} } == @$queue) {
1932 if (@$queue) { 3081 if (@$queue) {
… …
1934 } else { 3083 } else {
1935 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 3084 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1936 } 3085 }
1937 } 3086 }
1938 }, 3087 },
3088 on_exticmd => sub {
3089 my ($ns, $buf) = @_;
3090
3091 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3092
3093 if (ref $msg) {
3094 my ($type, $reply, @payload) =
3095 "ARRAY" eq ref $msg
3096 ? @$msg
3097 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3098
3099 my @reply;
3100
3101 if (my $cb = $EXTICMD{$type}) {
3102 @reply = $cb->($ns, @payload);
3103 }
3104
3105 $ns->ext_reply ($reply, @reply)
3106 if $reply;
3107
3108 } else {
3109 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3110 }
3111
3112 cf::override;
3113 },
1939); 3114);
1940 3115
1941=item $client->async (\&cb) 3116=item $client->async (\&cb)
1942 3117
1943Create a new coroutine, running the specified callback. The coroutine will 3118Create a new coroutine, running the specified callback. The coroutine will
… …
1984our $safe = new Safe "safe"; 3159our $safe = new Safe "safe";
1985our $safe_hole = new Safe::Hole; 3160our $safe_hole = new Safe::Hole;
1986 3161
1987$SIG{FPE} = 'IGNORE'; 3162$SIG{FPE} = 'IGNORE';
1988 3163
1989$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3164$safe->permit_only (Opcode::opset qw(
3165 :base_core :base_mem :base_orig :base_math :base_loop
3166 grepstart grepwhile mapstart mapwhile
3167 sort time
3168));
1990 3169
1991# here we export the classes and methods available to script code 3170# here we export the classes and methods available to script code
1992 3171
1993=pod 3172=pod
1994 3173
1995The following fucntions and emthods are available within a safe environment: 3174The following functions and methods are available within a safe environment:
1996 3175
1997 cf::object contr pay_amount pay_player map 3176 cf::object
3177 contr pay_amount pay_player map x y force_find force_add destroy
3178 insert remove name archname title slaying race decrease split
3179 value
3180
1998 cf::object::player player 3181 cf::object::player
1999 cf::player peaceful 3182 player
2000 cf::map trigger 3183
3184 cf::player
3185 peaceful
3186
3187 cf::map
3188 trigger
2001 3189
2002=cut 3190=cut
2003 3191
2004for ( 3192for (
2005 ["cf::object" => qw(contr pay_amount pay_player map)], 3193 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3194 insert remove inv nrof name archname title slaying race
3195 decrease split destroy change_exp value msg lore send_msg)],
2006 ["cf::object::player" => qw(player)], 3196 ["cf::object::player" => qw(player)],
2007 ["cf::player" => qw(peaceful)], 3197 ["cf::player" => qw(peaceful send_msg)],
2008 ["cf::map" => qw(trigger)], 3198 ["cf::map" => qw(trigger)],
2009) { 3199) {
2010 no strict 'refs'; 3200 no strict 'refs';
2011 my ($pkg, @funs) = @$_; 3201 my ($pkg, @funs) = @$_;
2012 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3202 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
2030 3220
2031 my $qcode = $code; 3221 my $qcode = $code;
2032 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3222 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2033 $qcode =~ s/\n/\\n/g; 3223 $qcode =~ s/\n/\\n/g;
2034 3224
3225 %vars = (_dummy => 0) unless %vars;
3226
3227 my @res;
2035 local $_; 3228 local $_;
2036 local @safe::cf::_safe_eval_args = values %vars;
2037 3229
2038 my $eval = 3230 my $eval =
2039 "do {\n" 3231 "do {\n"
2040 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3232 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
2041 . "#line 0 \"{$qcode}\"\n" 3233 . "#line 0 \"{$qcode}\"\n"
2042 . $code 3234 . $code
2043 . "\n}" 3235 . "\n}"
2044 ; 3236 ;
2045 3237
3238 if ($CFG{safe_eval}) {
2046 sub_generation_inc; 3239 sub_generation_inc;
3240 local @safe::cf::_safe_eval_args = values %vars;
2047 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3241 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
2048 sub_generation_inc; 3242 sub_generation_inc;
3243 } else {
3244 local @cf::_safe_eval_args = values %vars;
3245 @res = wantarray ? eval eval : scalar eval $eval;
3246 }
2049 3247
2050 if ($@) { 3248 if ($@) {
2051 warn "$@"; 3249 warn "$@";
2052 warn "while executing safe code '$code'\n"; 3250 warn "while executing safe code '$code'\n";
2053 warn "with arguments " . (join " ", %vars) . "\n"; 3251 warn "with arguments " . (join " ", %vars) . "\n";
… …
2072=cut 3270=cut
2073 3271
2074sub register_script_function { 3272sub register_script_function {
2075 my ($fun, $cb) = @_; 3273 my ($fun, $cb) = @_;
2076 3274
2077 no strict 'refs'; 3275 $fun = "safe::$fun" if $CFG{safe_eval};
2078 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3276 *$fun = $safe_hole->wrap ($cb);
2079} 3277}
2080 3278
2081=back 3279=back
2082 3280
2083=cut 3281=cut
2084 3282
2085############################################################################# 3283#############################################################################
3284# the server's init and main functions
2086 3285
2087=head2 EXTENSION DATABASE SUPPORT 3286sub load_facedata($) {
3287 my ($path) = @_;
2088 3288
2089Crossfire maintains a very simple database for extension use. It can 3289 # HACK to clear player env face cache, we need some signal framework
2090currently store anything that can be serialised using Storable, which 3290 # for this (global event?)
2091excludes objects. 3291 %ext::player_env::MUSIC_FACE_CACHE = ();
2092 3292
2093The parameter C<$family> should best start with the name of the extension 3293 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2094using it, it should be unique.
2095 3294
2096=over 4 3295 warn "loading facedata from $path\n";
2097 3296
2098=item $hashref = cf::db_get $family 3297 my $facedata;
3298 0 < aio_load $path, $facedata
3299 or die "$path: $!";
2099 3300
2100Return a hashref for use by the extension C<$family>, which can be 3301 $facedata = Coro::Storable::thaw $facedata;
2101modified. After modifications, you have to call C<cf::db_dirty> or
2102C<cf::db_sync>.
2103 3302
2104=item $value = cf::db_get $family => $key 3303 $facedata->{version} == 2
3304 or cf::cleanup "$path: version mismatch, cannot proceed.";
2105 3305
2106Returns a single value from the database 3306 # patch in the exptable
2107 3307 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
2108=item cf::db_put $family => $hashref 3308 $facedata->{resource}{"res/exp_table"} = {
2109 3309 type => FT_RSRC,
2110Stores the given family hashref into the database. Updates are delayed, if 3310 data => $exp_table,
2111you want the data to be synced to disk immediately, use C<cf::db_sync>. 3311 hash => (Digest::MD5::md5 $exp_table),
2112
2113=item cf::db_put $family => $key => $value
2114
2115Stores the given C<$value> in the family hash. Updates are delayed, if you
2116want the data to be synced to disk immediately, use C<cf::db_sync>.
2117
2118=item cf::db_dirty
2119
2120Marks the database as dirty, to be updated at a later time.
2121
2122=item cf::db_sync
2123
2124Immediately write the database to disk I<if it is dirty>.
2125
2126=cut
2127
2128our $DB;
2129
2130{
2131 my $path = cf::localdir . "/database.pst";
2132
2133 sub db_load() {
2134 $DB = stat $path ? Storable::retrieve $path : { };
2135 }
2136
2137 my $pid;
2138
2139 sub db_save() {
2140 waitpid $pid, 0 if $pid;
2141 if (0 == ($pid = fork)) {
2142 $DB->{_meta}{version} = 1;
2143 Storable::nstore $DB, "$path~";
2144 rename "$path~", $path;
2145 cf::_exit 0 if defined $pid;
2146 }
2147 }
2148
2149 my $dirty;
2150
2151 sub db_sync() {
2152 db_save if $dirty;
2153 undef $dirty;
2154 }
2155
2156 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
2157 db_sync;
2158 }); 3312 };
3313 cf::cede_to_tick;
2159 3314
2160 sub db_dirty() {
2161 $dirty = 1;
2162 $idle->start;
2163 } 3315 {
3316 my $faces = $facedata->{faceinfo};
2164 3317
2165 sub db_get($;$) { 3318 while (my ($face, $info) = each %$faces) {
2166 @_ >= 2 3319 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2167 ? $DB->{$_[0]}{$_[1]}
2168 : ($DB->{$_[0]} ||= { })
2169 }
2170 3320
2171 sub db_put($$;$) { 3321 cf::face::set_visibility $idx, $info->{visibility};
2172 if (@_ >= 3) { 3322 cf::face::set_magicmap $idx, $info->{magicmap};
2173 $DB->{$_[0]}{$_[1]} = $_[2]; 3323 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
2174 } else { 3324 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
2175 $DB->{$_[0]} = $_[1];
2176 }
2177 db_dirty;
2178 }
2179 3325
2180 cf::global->attach ( 3326 cf::cede_to_tick;
2181 prio => 10000,
2182 on_cleanup => sub {
2183 db_sync;
2184 }, 3327 }
2185 );
2186}
2187 3328
2188############################################################################# 3329 while (my ($face, $info) = each %$faces) {
2189# the server's main() 3330 next unless $info->{smooth};
2190 3331
2191sub cfg_load { 3332 my $idx = cf::face::find $face
3333 or next;
3334
3335 if (my $smooth = cf::face::find $info->{smooth}) {
3336 cf::face::set_smooth $idx, $smooth;
3337 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3338 } else {
3339 warn "smooth face '$info->{smooth}' not found for face '$face'";
3340 }
3341
3342 cf::cede_to_tick;
3343 }
3344 }
3345
3346 {
3347 my $anims = $facedata->{animinfo};
3348
3349 while (my ($anim, $info) = each %$anims) {
3350 cf::anim::set $anim, $info->{frames}, $info->{facings};
3351 cf::cede_to_tick;
3352 }
3353
3354 cf::anim::invalidate_all; # d'oh
3355 }
3356
3357 {
3358 my $res = $facedata->{resource};
3359
3360 while (my ($name, $info) = each %$res) {
3361 if (defined $info->{type}) {
3362 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3363
3364 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3365 cf::face::set_type $idx, $info->{type};
3366 } else {
3367 $RESOURCE{$name} = $info;
3368 }
3369
3370 cf::cede_to_tick;
3371 }
3372 }
3373
3374 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3375
3376 1
3377}
3378
3379cf::global->attach (on_resource_update => sub {
3380 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3381 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3382
3383 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3384 my $sound = $soundconf->{compat}[$_]
3385 or next;
3386
3387 my $face = cf::face::find "sound/$sound->[1]";
3388 cf::sound::set $sound->[0] => $face;
3389 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3390 }
3391
3392 while (my ($k, $v) = each %{$soundconf->{event}}) {
3393 my $face = cf::face::find "sound/$v";
3394 cf::sound::set $k => $face;
3395 }
3396 }
3397});
3398
3399register_exticmd fx_want => sub {
3400 my ($ns, $want) = @_;
3401
3402 while (my ($k, $v) = each %$want) {
3403 $ns->fx_want ($k, $v);
3404 }
3405};
3406
3407sub load_resource_file($) {
3408 my $guard = lock_acquire "load_resource_file";
3409
3410 my $status = load_resource_file_ $_[0];
3411 get_slot 0.1, 100;
3412 cf::arch::commit_load;
3413
3414 $status
3415}
3416
3417sub reload_regions {
3418 # HACK to clear player env face cache, we need some signal framework
3419 # for this (global event?)
3420 %ext::player_env::MUSIC_FACE_CACHE = ();
3421
3422 load_resource_file "$MAPDIR/regions"
3423 or die "unable to load regions file\n";
3424
3425 for (cf::region::list) {
3426 $_->{match} = qr/$_->{match}/
3427 if exists $_->{match};
3428 }
3429}
3430
3431sub reload_facedata {
3432 load_facedata "$DATADIR/facedata"
3433 or die "unable to load facedata\n";
3434}
3435
3436sub reload_archetypes {
3437 load_resource_file "$DATADIR/archetypes"
3438 or die "unable to load archetypes\n";
3439}
3440
3441sub reload_treasures {
3442 load_resource_file "$DATADIR/treasures"
3443 or die "unable to load treasurelists\n";
3444}
3445
3446sub reload_resources {
3447 warn "reloading resource files...\n";
3448
3449 reload_facedata;
3450 reload_archetypes;
3451 reload_regions;
3452 reload_treasures;
3453
3454 warn "finished reloading resource files\n";
3455}
3456
3457sub reload_config {
3458 warn "reloading config file...\n";
3459
2192 open my $fh, "<:utf8", cf::confdir . "/config" 3460 open my $fh, "<:utf8", "$CONFDIR/config"
2193 or return; 3461 or return;
2194 3462
2195 local $/; 3463 local $/;
2196 *CFG = YAML::Syck::Load <$fh>; 3464 *CFG = YAML::XS::Load scalar <$fh>;
2197 3465
2198 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3466 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2199 3467
2200 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3468 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2201 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3469 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
2205 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3473 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2206 and die "WARNING: m(un)lockall failed: $!\n"; 3474 and die "WARNING: m(un)lockall failed: $!\n";
2207 }; 3475 };
2208 warn $@ if $@; 3476 warn $@ if $@;
2209 } 3477 }
3478
3479 warn "finished reloading resource files\n";
3480}
3481
3482sub pidfile() {
3483 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3484 or die "$PIDFILE: $!";
3485 flock $fh, &Fcntl::LOCK_EX
3486 or die "$PIDFILE: flock: $!";
3487 $fh
3488}
3489
3490# make sure only one server instance is running at any one time
3491sub atomic {
3492 my $fh = pidfile;
3493
3494 my $pid = <$fh>;
3495 kill 9, $pid if $pid > 0;
3496
3497 seek $fh, 0, 0;
3498 print $fh $$;
3499}
3500
3501sub main_loop {
3502 warn "EV::loop starting\n";
3503 if (1) {
3504 EV::loop;
3505 }
3506 warn "EV::loop returned\n";
3507 goto &main_loop unless $REALLY_UNLOOP;
2210} 3508}
2211 3509
2212sub main { 3510sub main {
3511 cf::init_globals; # initialise logging
3512
3513 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3514 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3515 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3516 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3517
3518 cf::init_experience;
3519 cf::init_anim;
3520 cf::init_attackmess;
3521 cf::init_dynamic;
3522
3523 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3524
2213 # we must not ever block the main coroutine 3525 # we must not ever block the main coroutine
2214 local $Coro::idle = sub { 3526 local $Coro::idle = sub {
2215 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3527 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2216 async { Event::one_event }; 3528 (async {
3529 $Coro::current->{desc} = "IDLE BUG HANDLER";
3530 EV::loop EV::LOOP_ONESHOT;
3531 })->prio (Coro::PRIO_MAX);
2217 }; 3532 };
2218 3533
2219 cfg_load; 3534 evthread_start IO::AIO::poll_fileno;
2220 db_load; 3535
3536 cf::sync_job {
3537 cf::load_settings;
3538 cf::load_materials;
3539
3540 reload_resources;
3541 reload_config;
3542 db_init;
3543
3544 cf::init_uuid;
3545 cf::init_signals;
3546 cf::init_commands;
3547 cf::init_skills;
3548
3549 cf::init_beforeplay;
3550
3551 atomic;
3552
2221 load_extensions; 3553 load_extensions;
2222 Event::loop; 3554
3555 utime time, time, $RUNTIMEFILE;
3556
3557 # no (long-running) fork's whatsoever before this point(!)
3558 use POSIX ();
3559 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3560
3561 (pop @POST_INIT)->(0) while @POST_INIT;
3562 };
3563
3564 main_loop;
2223} 3565}
2224 3566
2225############################################################################# 3567#############################################################################
2226# initialisation and cleanup 3568# initialisation and cleanup
2227 3569
2228# install some emergency cleanup handlers 3570# install some emergency cleanup handlers
2229BEGIN { 3571BEGIN {
3572 our %SIGWATCHER = ();
2230 for my $signal (qw(INT HUP TERM)) { 3573 for my $signal (qw(INT HUP TERM)) {
2231 Event->signal ( 3574 $SIGWATCHER{$signal} = EV::signal $signal, sub {
2232 data => WF_AUTOCANCEL,
2233 signal => $signal,
2234 cb => sub {
2235 cf::cleanup "SIG$signal"; 3575 cf::cleanup "SIG$signal";
2236 },
2237 ); 3576 };
3577 }
3578}
3579
3580sub write_runtime_sync {
3581 my $t0 = EV::time;
3582
3583 # first touch the runtime file to show we are still running:
3584 # the fsync below can take a very very long time.
3585
3586 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3587
3588 my $guard = cf::lock_acquire "write_runtime";
3589
3590 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3591 or return;
3592
3593 my $value = $cf::RUNTIME + 90 + 10;
3594 # 10 is the runtime save interval, for a monotonic clock
3595 # 60 allows for the watchdog to kill the server.
3596
3597 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3598 and return;
3599
3600 # always fsync - this file is important
3601 aio_fsync $fh
3602 and return;
3603
3604 # touch it again to show we are up-to-date
3605 aio_utime $fh, undef, undef;
3606
3607 close $fh
3608 or return;
3609
3610 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3611 and return;
3612
3613 warn sprintf "runtime file written (%gs).\n", EV::time - $t0;
3614
2238 } 3615 1
3616}
3617
3618our $uuid_lock;
3619our $uuid_skip;
3620
3621sub write_uuid_sync($) {
3622 $uuid_skip ||= $_[0];
3623
3624 return if $uuid_lock;
3625 local $uuid_lock = 1;
3626
3627 my $uuid = "$LOCALDIR/uuid";
3628
3629 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3630 or return;
3631
3632 my $value = uuid_seq uuid_cur;
3633
3634 unless ($value) {
3635 warn "cowardly refusing to write zero uuid value!\n";
3636 return;
3637 }
3638
3639 my $value = uuid_str $value + $uuid_skip;
3640 $uuid_skip = 0;
3641
3642 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3643 and return;
3644
3645 # always fsync - this file is important
3646 aio_fsync $fh
3647 and return;
3648
3649 close $fh
3650 or return;
3651
3652 aio_rename "$uuid~", $uuid
3653 and return;
3654
3655 warn "uuid file written ($value).\n";
3656
3657 1
3658
3659}
3660
3661sub write_uuid($$) {
3662 my ($skip, $sync) = @_;
3663
3664 $sync ? write_uuid_sync $skip
3665 : async { write_uuid_sync $skip };
2239} 3666}
2240 3667
2241sub emergency_save() { 3668sub emergency_save() {
2242 my $freeze_guard = cf::freeze_mainloop; 3669 my $freeze_guard = cf::freeze_mainloop;
2243 3670
2244 warn "enter emergency perl save\n"; 3671 warn "emergency_perl_save: enter\n";
2245 3672
2246 cf::sync_job { 3673 cf::sync_job {
3674 # this is a trade-off: we want to be very quick here, so
3675 # save all maps without fsync, and later call a global sync
3676 # (which in turn might be very very slow)
3677 local $USE_FSYNC = 0;
3678
2247 # use a peculiar iteration method to avoid tripping on perl 3679 # use a peculiar iteration method to avoid tripping on perl
2248 # refcount bugs in for. also avoids problems with players 3680 # refcount bugs in for. also avoids problems with players
2249 # and maps saved/destroyed asynchronously. 3681 # and maps saved/destroyed asynchronously.
2250 warn "begin emergency player save\n"; 3682 warn "emergency_perl_save: begin player save\n";
2251 for my $login (keys %cf::PLAYER) { 3683 for my $login (keys %cf::PLAYER) {
2252 my $pl = $cf::PLAYER{$login} or next; 3684 my $pl = $cf::PLAYER{$login} or next;
2253 $pl->valid or next; 3685 $pl->valid or next;
3686 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2254 $pl->save; 3687 $pl->save;
2255 } 3688 }
2256 warn "end emergency player save\n"; 3689 warn "emergency_perl_save: end player save\n";
2257 3690
2258 warn "begin emergency map save\n"; 3691 warn "emergency_perl_save: begin map save\n";
2259 for my $path (keys %cf::MAP) { 3692 for my $path (keys %cf::MAP) {
2260 my $map = $cf::MAP{$path} or next; 3693 my $map = $cf::MAP{$path} or next;
2261 $map->valid or next; 3694 $map->valid or next;
2262 $map->save; 3695 $map->save;
2263 } 3696 }
2264 warn "end emergency map save\n"; 3697 warn "emergency_perl_save: end map save\n";
3698
3699 warn "emergency_perl_save: begin database checkpoint\n";
3700 BDB::db_env_txn_checkpoint $DB_ENV;
3701 warn "emergency_perl_save: end database checkpoint\n";
3702
3703 warn "emergency_perl_save: begin write uuid\n";
3704 write_uuid_sync 1;
3705 warn "emergency_perl_save: end write uuid\n";
2265 }; 3706 };
2266 3707
3708 warn "emergency_perl_save: starting sync()\n";
3709 IO::AIO::aio_sync sub {
3710 warn "emergency_perl_save: finished sync()\n";
3711 };
3712
2267 warn "leave emergency perl save\n"; 3713 warn "emergency_perl_save: leave\n";
2268} 3714}
2269 3715
3716sub post_cleanup {
3717 my ($make_core) = @_;
3718
3719 warn Carp::longmess "post_cleanup backtrace"
3720 if $make_core;
3721
3722 my $fh = pidfile;
3723 unlink $PIDFILE if <$fh> == $$;
3724}
3725
3726# a safer delete_package, copied from Symbol
3727sub clear_package($) {
3728 my $pkg = shift;
3729
3730 # expand to full symbol table name if needed
3731 unless ($pkg =~ /^main::.*::$/) {
3732 $pkg = "main$pkg" if $pkg =~ /^::/;
3733 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3734 $pkg .= '::' unless $pkg =~ /::$/;
3735 }
3736
3737 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3738 my $stem_symtab = *{$stem}{HASH};
3739
3740 defined $stem_symtab and exists $stem_symtab->{$leaf}
3741 or return;
3742
3743 # clear all symbols
3744 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3745 for my $name (keys %$leaf_symtab) {
3746 _gv_clear *{"$pkg$name"};
3747# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3748 }
3749 warn "cleared package $pkg\n";#d#
3750}
3751
2270sub reload() { 3752sub do_reload_perl() {
2271 # can/must only be called in main 3753 # can/must only be called in main
2272 if ($Coro::current != $Coro::main) { 3754 if ($Coro::current != $Coro::main) {
2273 warn "can only reload from main coroutine\n"; 3755 warn "can only reload from main coroutine";
2274 return; 3756 return;
2275 } 3757 }
2276 3758
3759 return if $RELOAD++;
3760
3761 my $t1 = EV::time;
3762
3763 while ($RELOAD) {
2277 warn "reloading..."; 3764 warn "reloading...";
2278 3765
2279 warn "freezing server"; 3766 warn "entering sync_job";
2280 my $guard = freeze_mainloop; 3767
3768 cf::sync_job {
3769 cf::write_runtime_sync; # external watchdog should not bark
2281 cf::emergency_save; 3770 cf::emergency_save;
3771 cf::write_runtime_sync; # external watchdog should not bark
2282 3772
2283 warn "sync database to disk"; 3773 warn "syncing database to disk";
2284 cf::db_sync; 3774 BDB::db_env_txn_checkpoint $DB_ENV;
2285 IO::AIO::flush;
2286 3775
2287 eval {
2288 # if anything goes wrong in here, we should simply crash as we already saved 3776 # if anything goes wrong in here, we should simply crash as we already saved
2289 3777
2290 warn "cancel all watchers"; 3778 warn "flushing outstanding aio requests";
2291 for (Event::all_watchers) { 3779 while (IO::AIO::nreqs || BDB::nreqs) {
2292 $_->cancel if $_->data & WF_AUTOCANCEL; 3780 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
2293 }
2294
2295 warn "cancel all extension coros";
2296 $_->cancel for values %EXT_CORO;
2297 %EXT_CORO = ();
2298
2299 warn "remove commands";
2300 %COMMAND = ();
2301
2302 warn "remove ext commands";
2303 %EXTCMD = ();
2304
2305 warn "unload/nuke all extensions";
2306 for my $pkg (@EXTS) {
2307 warn "... unloading $pkg";
2308
2309 if (my $cb = $pkg->can ("unload")) {
2310 eval {
2311 $cb->($pkg);
2312 1
2313 } or warn "$pkg unloaded, but with errors: $@";
2314 } 3781 }
2315 3782
3783 warn "cancelling all extension coros";
3784 $_->cancel for values %EXT_CORO;
3785 %EXT_CORO = ();
3786
3787 warn "removing commands";
3788 %COMMAND = ();
3789
3790 warn "removing ext/exti commands";
3791 %EXTCMD = ();
3792 %EXTICMD = ();
3793
3794 warn "unloading/nuking all extensions";
3795 for my $pkg (@EXTS) {
2316 warn "... nuking $pkg"; 3796 warn "... unloading $pkg";
2317 Symbol::delete_package $pkg;
2318 }
2319 3797
2320 warn "unload all perl modules loaded from $LIBDIR";
2321 while (my ($k, $v) = each %INC) {
2322 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2323
2324 warn "removing <$k>";
2325 delete $INC{$k};
2326
2327 $k =~ s/\.pm$//;
2328 $k =~ s/\//::/g;
2329
2330 if (my $cb = $k->can ("unload_module")) { 3798 if (my $cb = $pkg->can ("unload")) {
3799 eval {
2331 $cb->(); 3800 $cb->($pkg);
3801 1
3802 } or warn "$pkg unloaded, but with errors: $@";
3803 }
3804
3805 warn "... clearing $pkg";
3806 clear_package $pkg;
2332 } 3807 }
2333 3808
2334 Symbol::delete_package $k; 3809 warn "unloading all perl modules loaded from $LIBDIR";
3810 while (my ($k, $v) = each %INC) {
3811 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3812
3813 warn "... unloading $k";
3814 delete $INC{$k};
3815
3816 $k =~ s/\.pm$//;
3817 $k =~ s/\//::/g;
3818
3819 if (my $cb = $k->can ("unload_module")) {
3820 $cb->();
3821 }
3822
3823 clear_package $k;
2335 } 3824 }
2336 3825
2337 warn "get rid of safe::, as good as possible"; 3826 warn "getting rid of safe::, as good as possible";
2338 Symbol::delete_package "safe::$_" 3827 clear_package "safe::$_"
2339 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3828 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2340 3829
2341 warn "unload cf.pm \"a bit\""; 3830 warn "unloading cf.pm \"a bit\"";
2342 delete $INC{"cf.pm"}; 3831 delete $INC{"cf.pm"};
3832 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
2343 3833
2344 # don't, removes xs symbols, too, 3834 # don't, removes xs symbols, too,
2345 # and global variables created in xs 3835 # and global variables created in xs
2346 #Symbol::delete_package __PACKAGE__; 3836 #clear_package __PACKAGE__;
2347 3837
3838 warn "unload completed, starting to reload now";
3839
2348 warn "reloading cf.pm"; 3840 warn "reloading cf.pm";
2349 require cf; 3841 require cf;
2350 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3842 cf::_connect_to_perl_1;
2351 3843
2352 warn "load config and database again"; 3844 warn "loading config and database again";
2353 cf::cfg_load; 3845 cf::reload_config;
2354 cf::db_load;
2355 3846
2356 warn "load extensions"; 3847 warn "loading extensions";
2357 cf::load_extensions; 3848 cf::load_extensions;
2358 3849
3850 if ($REATTACH_ON_RELOAD) {
2359 warn "reattach attachments to objects/players"; 3851 warn "reattaching attachments to objects/players";
2360 _global_reattach; 3852 _global_reattach; # objects, sockets
2361 warn "reattach attachments to maps"; 3853 warn "reattaching attachments to maps";
2362 reattach $_ for values %MAP; 3854 reattach $_ for values %MAP;
3855 warn "reattaching attachments to players";
3856 reattach $_ for values %PLAYER;
3857 }
3858
3859 warn "running post_init jobs";
3860 (pop @POST_INIT)->(1) while @POST_INIT;
3861
3862 warn "leaving sync_job";
3863
3864 1
3865 } or do {
3866 warn $@;
3867 cf::cleanup "error while reloading, exiting.";
3868 };
3869
3870 warn "reloaded";
3871 --$RELOAD;
3872 }
3873
3874 $t1 = EV::time - $t1;
3875 warn "reload completed in ${t1}s\n";
3876};
3877
3878our $RELOAD_WATCHER; # used only during reload
3879
3880sub reload_perl() {
3881 # doing reload synchronously and two reloads happen back-to-back,
3882 # coro crashes during coro_state_free->destroy here.
3883
3884 $RELOAD_WATCHER ||= cf::async {
3885 Coro::AIO::aio_wait cache_extensions;
3886
3887 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {
3888 do_reload_perl;
3889 undef $RELOAD_WATCHER;
3890 };
2363 }; 3891 };
2364 3892}
2365 if ($@) {
2366 warn $@;
2367 warn "error while reloading, exiting.";
2368 exit 1;
2369 }
2370
2371 warn "reloaded";
2372};
2373 3893
2374register_command "reload" => sub { 3894register_command "reload" => sub {
2375 my ($who, $arg) = @_; 3895 my ($who, $arg) = @_;
2376 3896
2377 if ($who->flag (FLAG_WIZ)) { 3897 if ($who->flag (FLAG_WIZ)) {
2378 $who->message ("start of reload.");
2379 reload;
2380 $who->message ("end of reload."); 3898 $who->message ("reloading server.");
3899 async {
3900 $Coro::current->{desc} = "perl_reload";
3901 reload_perl;
3902 };
2381 } 3903 }
2382}; 3904};
2383 3905
2384unshift @INC, $LIBDIR; 3906unshift @INC, $LIBDIR;
2385 3907
2386$TICK_WATCHER = Event->timer ( 3908my $bug_warning = 0;
2387 reentrant => 0,
2388 prio => 0,
2389 at => $NEXT_TICK || $TICK,
2390 data => WF_AUTOCANCEL,
2391 cb => sub {
2392 $NOW = Event::time;
2393 3909
3910our @WAIT_FOR_TICK;
3911our @WAIT_FOR_TICK_BEGIN;
3912
3913sub wait_for_tick {
3914 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3915
3916 my $signal = new Coro::Signal;
3917 push @WAIT_FOR_TICK, $signal;
3918 $signal->wait;
3919}
3920
3921sub wait_for_tick_begin {
3922 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3923
3924 my $signal = new Coro::Signal;
3925 push @WAIT_FOR_TICK_BEGIN, $signal;
3926 $signal->wait;
3927}
3928
3929sub tick {
3930 if ($Coro::current != $Coro::main) {
3931 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3932 unless ++$bug_warning > 10;
3933 return;
3934 }
3935
2394 cf::server_tick; # one server iteration 3936 cf::server_tick; # one server iteration
2395 $RUNTIME += $TICK;
2396 $NEXT_TICK += $TICK;
2397 3937
2398 $WAIT_FOR_TICK->broadcast; 3938 #for(1..3e6){} EV::now_update; $NOW=EV::now; # generate load #d#
2399 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2400 3939
2401 # if we are delayed by four ticks or more, skip them all 3940 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2402 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3941 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2403 3942 Coro::async_pool {
2404 $TICK_WATCHER->at ($NEXT_TICK); 3943 $Coro::current->{desc} = "runtime saver";
2405 $TICK_WATCHER->start;
2406 },
2407);
2408
2409IO::AIO::max_poll_time $TICK * 0.2;
2410
2411$AIO_POLL_WATCHER = Event->io (
2412 fd => IO::AIO::poll_fileno,
2413 poll => 'r',
2414 prio => 5,
2415 data => WF_AUTOCANCEL,
2416 cb => \&IO::AIO::poll_cb,
2417);
2418
2419$WRITE_RUNTIME_WATCHER = Event->timer (
2420 data => WF_AUTOCANCEL,
2421 after => 0,
2422 interval => 10,
2423 cb => sub {
2424 (Coro::unblock_sub {
2425 write_runtime 3944 write_runtime_sync
2426 or warn "ERROR: unable to write runtime file: $!"; 3945 or warn "ERROR: unable to write runtime file: $!";
2427 })->(); 3946 };
2428 }, 3947 }
2429); 3948
3949 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3950 $sig->send;
3951 }
3952 while (my $sig = shift @WAIT_FOR_TICK) {
3953 $sig->send;
3954 }
3955
3956 $LOAD = ($NOW - $TICK_START) / $TICK;
3957 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3958
3959 if (0) {
3960 if ($NEXT_TICK) {
3961 my $jitter = $TICK_START - $NEXT_TICK;
3962 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3963 warn "jitter $JITTER\n";#d#
3964 }
3965 }
3966}
3967
3968{
3969 # configure BDB
3970
3971 BDB::min_parallel 16;
3972 BDB::max_poll_reqs $TICK * 0.1;
3973 $AnyEvent::BDB::WATCHER->priority (1);
3974
3975 unless ($DB_ENV) {
3976 $DB_ENV = BDB::db_env_create;
3977 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3978 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3979 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3980 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3981 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3982
3983 cf::sync_job {
3984 eval {
3985 BDB::db_env_open
3986 $DB_ENV,
3987 $BDBDIR,
3988 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3989 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3990 0666;
3991
3992 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3993 };
3994
3995 cf::cleanup "db_env_open(db): $@" if $@;
3996 };
3997 }
3998
3999 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
4000 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
4001 };
4002 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
4003 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4004 };
4005 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4006 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4007 };
4008}
4009
4010{
4011 # configure IO::AIO
4012
4013 IO::AIO::min_parallel 8;
4014 IO::AIO::max_poll_time $TICK * 0.1;
4015 undef $AnyEvent::AIO::WATCHER;
4016}
4017
4018my $_log_backtrace;
4019
4020sub _log_backtrace {
4021 my ($msg, @addr) = @_;
4022
4023 $msg =~ s/\n//;
4024
4025 # limit the # of concurrent backtraces
4026 if ($_log_backtrace < 2) {
4027 ++$_log_backtrace;
4028 my $perl_bt = Carp::longmess $msg;
4029 async {
4030 $Coro::current->{desc} = "abt $msg";
4031
4032 my @bt = fork_call {
4033 @addr = map { sprintf "%x", $_ } @addr;
4034 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
4035 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
4036 or die "addr2line: $!";
4037
4038 my @funcs;
4039 my @res = <$fh>;
4040 chomp for @res;
4041 while (@res) {
4042 my ($func, $line) = splice @res, 0, 2, ();
4043 push @funcs, "[$func] $line";
4044 }
4045
4046 @funcs
4047 };
4048
4049 LOG llevInfo, "[ABT] $perl_bt\n";
4050 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
4051 LOG llevInfo, "[ABT] $_\n" for @bt;
4052 --$_log_backtrace;
4053 };
4054 } else {
4055 LOG llevInfo, "[ABT] $msg\n";
4056 LOG llevInfo, "[ABT] [suppressed]\n";
4057 }
4058}
4059
4060# load additional modules
4061require "cf/$_.pm" for @EXTRA_MODULES;
4062cf::_connect_to_perl_2;
2430 4063
2431END { cf::emergency_save } 4064END { cf::emergency_save }
2432 4065
24331 40661
2434 4067

Diff Legend

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