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.131 by root, Thu Jan 4 00:53:54 2007 UTC vs.
Revision 1.418 by root, Fri Apr 11 21:09:53 2008 UTC

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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines