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.137 by root, Fri Jan 5 10:23:05 2007 UTC vs.
Revision 1.462 by root, Tue Dec 23 06:58:23 2008 UTC

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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines