ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
(Generate patch)

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.183 by root, Fri Jan 19 19:42:37 2007 UTC vs.
Revision 1.314 by root, Mon Jul 23 16:53:15 2007 UTC

3use utf8; 3use utf8;
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket;
8use Storable; 9use Storable;
10use Event;
9use Opcode; 11use Opcode;
10use Safe; 12use Safe;
11use Safe::Hole; 13use Safe::Hole;
12 14
13use Coro 3.4 (); 15use Coro 3.61 ();
16use Coro::State;
17use Coro::Handle;
14use Coro::Event; 18use Coro::Event;
15use Coro::Timer; 19use Coro::Timer;
16use Coro::Signal; 20use Coro::Signal;
17use Coro::Semaphore; 21use Coro::Semaphore;
18use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable;
19 24
25use JSON::XS 1.4 ();
26use BDB ();
20use Data::Dumper; 27use Data::Dumper;
21use Digest::MD5; 28use Digest::MD5;
22use Fcntl; 29use Fcntl;
30use YAML::Syck ();
23use IO::AIO 2.32 (); 31use IO::AIO 2.32 ();
24use YAML::Syck ();
25use Time::HiRes; 32use Time::HiRes;
33use Compress::LZF;
34use Digest::MD5 ();
26 35
36# configure various modules to our taste
37#
38$Storable::canonical = 1; # reduce rsync transfers
39Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
40Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
41
27use Event; $Event::Eval = 1; # no idea why this is required, but it is 42$Event::Eval = 1; # no idea why this is required, but it is
28
29sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
30 43
31# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 44# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
32$YAML::Syck::ImplicitUnicode = 1; 45$YAML::Syck::ImplicitUnicode = 1;
33 46
34$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 47$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
35 48
49sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
50
36our %COMMAND = (); 51our %COMMAND = ();
37our %COMMAND_TIME = (); 52our %COMMAND_TIME = ();
38 53
39our @EXTS = (); # list of extension package names 54our @EXTS = (); # list of extension package names
40our %EXTCMD = (); 55our %EXTCMD = ();
56our %EXTICMD = ();
41our %EXT_CORO = (); # coroutines bound to extensions 57our %EXT_CORO = (); # coroutines bound to extensions
42our %EXT_MAP = (); # pluggable maps 58our %EXT_MAP = (); # pluggable maps
43 59
60our $RELOAD; # number of reloads so far
44our @EVENT; 61our @EVENT;
45our $LIBDIR = datadir . "/ext";
46 62
47our $TICK = MAX_TIME * 1e-6; 63our $CONFDIR = confdir;
64our $DATADIR = datadir;
65our $LIBDIR = "$DATADIR/ext";
66our $PODDIR = "$DATADIR/pod";
67our $MAPDIR = "$DATADIR/" . mapdir;
68our $LOCALDIR = localdir;
69our $TMPDIR = "$LOCALDIR/" . tmpdir;
70our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
71our $PLAYERDIR = "$LOCALDIR/" . playerdir;
72our $RANDOMDIR = "$LOCALDIR/random";
73our $BDBDIR = "$LOCALDIR/db";
74
75our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
48our $TICK_WATCHER; 76our $TICK_WATCHER;
49our $AIO_POLL_WATCHER; 77our $AIO_POLL_WATCHER;
50our $WRITE_RUNTIME_WATCHER; 78our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
51our $NEXT_TICK; 79our $NEXT_TICK;
52our $NOW; 80our $NOW;
81our $USE_FSYNC = 1; # use fsync to write maps - default off
82
83our $BDB_POLL_WATCHER;
84our $DB_ENV;
53 85
54our %CFG; 86our %CFG;
55 87
56our $UPTIME; $UPTIME ||= time; 88our $UPTIME; $UPTIME ||= time;
57our $RUNTIME; 89our $RUNTIME;
58 90
59our %PLAYER; # all users 91our %PLAYER; # all users
60our %MAP; # all maps 92our %MAP; # all maps
61our $LINK_MAP; # the special {link} map, which is always available 93our $LINK_MAP; # the special {link} map, which is always available
62our $RANDOM_MAPS = cf::localdir . "/random";
63
64our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
65our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
66 94
67# used to convert map paths into valid unix filenames by replacing / by ∕ 95# used to convert map paths into valid unix filenames by replacing / by ∕
68our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 96our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
69 97
98our $LOAD; # a number between 0 (idle) and 1 (too many objects)
99our $LOADAVG; # same thing, but with alpha-smoothing
100our $tick_start; # for load detecting purposes
101
70binmode STDOUT; 102binmode STDOUT;
71binmode STDERR; 103binmode STDERR;
72 104
73# read virtual server time, if available 105# read virtual server time, if available
74unless ($RUNTIME || !-e cf::localdir . "/runtime") { 106unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
75 open my $fh, "<", cf::localdir . "/runtime" 107 open my $fh, "<", "$LOCALDIR/runtime"
76 or die "unable to read runtime file: $!"; 108 or die "unable to read runtime file: $!";
77 $RUNTIME = <$fh> + 0.; 109 $RUNTIME = <$fh> + 0.;
78} 110}
79 111
80mkdir cf::localdir; 112mkdir $_
81mkdir cf::localdir . "/" . cf::playerdir; 113 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
82mkdir cf::localdir . "/" . cf::tmpdir;
83mkdir cf::localdir . "/" . cf::uniquedir;
84mkdir $RANDOM_MAPS;
85 114
86our $EMERGENCY_POSITION; 115our $EMERGENCY_POSITION;
116
117sub cf::map::normalise;
87 118
88############################################################################# 119#############################################################################
89 120
90=head2 GLOBAL VARIABLES 121=head2 GLOBAL VARIABLES
91 122
98=item $cf::RUNTIME 129=item $cf::RUNTIME
99 130
100The time this server has run, starts at 0 and is increased by $cf::TICK on 131The time this server has run, starts at 0 and is increased by $cf::TICK on
101every server tick. 132every server tick.
102 133
103=item $cf::LIBDIR 134=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
135$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
136$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
104 137
105The perl library directory, where extensions and cf-specific modules can 138Various directories - "/etc", read-only install directory, perl-library
106be found. It will be added to C<@INC> automatically. 139directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
140unique-items directory, player file directory, random maps directory and
141database environment.
107 142
108=item $cf::NOW 143=item $cf::NOW
109 144
110The time of the last (current) server tick. 145The time of the last (current) server tick.
111 146
112=item $cf::TICK 147=item $cf::TICK
113 148
114The interval between server ticks, in seconds. 149The interval between server ticks, in seconds.
150
151=item $cf::LOADAVG
152
153The current CPU load on the server (alpha-smoothed), as a value between 0
154(none) and 1 (overloaded), indicating how much time is spent on processing
155objects per tick. Healthy values are < 0.5.
156
157=item $cf::LOAD
158
159The raw value load value from the last tick.
115 160
116=item %cf::CFG 161=item %cf::CFG
117 162
118Configuration for the server, loaded from C</etc/crossfire/config>, or 163Configuration for the server, loaded from C</etc/crossfire/config>, or
119from wherever your confdir points to. 164from wherever your confdir points to.
120 165
121=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 166=item cf::wait_for_tick, cf::wait_for_tick_begin
122 167
123These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK) 168These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
124or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick 169returns directly I<after> the tick processing (and consequently, can only wake one process
125processing has been done. Call C<< ->wait >> on them to maximise the 170per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
126window of cpu time available, or simply to synchronise to the server tick. 171
172=item @cf::INVOKE_RESULTS
173
174This array contains the results of the last C<invoke ()> call. When
175C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
176that call.
127 177
128=back 178=back
129 179
130=cut 180=cut
131 181
132BEGIN { 182BEGIN {
133 *CORE::GLOBAL::warn = sub { 183 *CORE::GLOBAL::warn = sub {
134 my $msg = join "", @_; 184 my $msg = join "", @_;
135 utf8::encode $msg;
136 185
137 $msg .= "\n" 186 $msg .= "\n"
138 unless $msg =~ /\n$/; 187 unless $msg =~ /\n$/;
139 188
189 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
190
191 utf8::encode $msg;
140 LOG llevError, $msg; 192 LOG llevError, $msg;
141 }; 193 };
142} 194}
143 195
144@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 196@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
145@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 197@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
146@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 198@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
147@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 199@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
148@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 200@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
201@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
149@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 202@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
150 203
151# we bless all objects into (empty) derived classes to force a method lookup 204# we bless all objects into (empty) derived classes to force a method lookup
152# within the Safe compartment. 205# within the Safe compartment.
153for my $pkg (qw( 206for my $pkg (qw(
154 cf::global cf::attachable 207 cf::global cf::attachable
162} 215}
163 216
164$Event::DIED = sub { 217$Event::DIED = sub {
165 warn "error in event callback: @_"; 218 warn "error in event callback: @_";
166}; 219};
220
221#############################################################################
167 222
168=head2 UTILITY FUNCTIONS 223=head2 UTILITY FUNCTIONS
169 224
170=over 4 225=over 4
171 226
190 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 245 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
191 $d 246 $d
192 } || "[unable to dump $_[0]: '$@']"; 247 } || "[unable to dump $_[0]: '$@']";
193} 248}
194 249
195use JSON::Syck (); # TODO# replace by JSON::PC once working
196
197=item $ref = cf::from_json $json 250=item $ref = cf::from_json $json
198 251
199Converts a JSON string into the corresponding perl data structure. 252Converts a JSON string into the corresponding perl data structure.
200 253
201=cut
202
203sub from_json($) {
204 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
205 JSON::Syck::Load $_[0]
206}
207
208=item $json = cf::to_json $ref 254=item $json = cf::to_json $ref
209 255
210Converts a perl data structure into its JSON representation. 256Converts a perl data structure into its JSON representation.
211 257
212=cut 258=cut
213 259
214sub to_json($) { 260our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
215 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 261
216 JSON::Syck::Dump $_[0] 262sub to_json ($) { $json_coder->encode ($_[0]) }
217} 263sub from_json ($) { $json_coder->decode ($_[0]) }
218 264
219=item cf::lock_wait $string 265=item cf::lock_wait $string
220 266
221Wait until the given lock is available. See cf::lock_acquire. 267Wait until the given lock is available. See cf::lock_acquire.
222 268
228returned. 274returned.
229 275
230Lock names should begin with a unique identifier (for example, cf::map::find 276Lock names should begin with a unique identifier (for example, cf::map::find
231uses map_find and cf::map::load uses map_load). 277uses map_find and cf::map::load uses map_load).
232 278
279=item $locked = cf::lock_active $string
280
281Return true if the lock is currently active, i.e. somebody has locked it.
282
233=cut 283=cut
234 284
235our %LOCK; 285our %LOCK;
236 286
237sub lock_wait($) { 287sub lock_wait($) {
256 # wake up all waiters, to be on the safe side 306 # wake up all waiters, to be on the safe side
257 $_->ready for @{ delete $LOCK{$key} }; 307 $_->ready for @{ delete $LOCK{$key} };
258 } 308 }
259} 309}
260 310
311sub lock_active($) {
312 my ($key) = @_;
313
314 ! ! $LOCK{$key}
315}
316
261sub freeze_mainloop { 317sub freeze_mainloop {
262 return unless $TICK_WATCHER->is_active; 318 return unless $TICK_WATCHER->is_active;
263 319
264 my $guard = Coro::guard { 320 my $guard = Coro::guard {
265 $TICK_WATCHER->start; 321 $TICK_WATCHER->start;
266 $WRITE_RUNTIME_WATCHER->start;
267 }; 322 };
268 $WRITE_RUNTIME_WATCHER->stop;
269 $TICK_WATCHER->stop; 323 $TICK_WATCHER->stop;
270 $guard 324 $guard
325}
326
327=item cf::get_slot $time[, $priority]
328
329Allocate $time seconds of blocking CPU time at priority C<$priority>:
330This call blocks and returns only when you have at least C<$time> seconds
331of cpu time till the next tick. The slot is only valid till the next cede.
332
333Useful for short background jobs.
334
335=cut
336
337our @SLOT_QUEUE;
338our $SLOT_QUEUE;
339
340$SLOT_QUEUE->cancel if $SLOT_QUEUE;
341$SLOT_QUEUE = Coro::async {
342 my $signal = new Coro::Signal;
343
344 while () {
345 next_job:
346 my $avail = cf::till_tick;
347 if ($avail > 0.01) {
348 for (0 .. $#SLOT_QUEUE) {
349 if ($SLOT_QUEUE[$_][0] < $avail) {
350 my $job = splice @SLOT_QUEUE, $_, 1, ();
351 $job->[2]->send;
352 Coro::cede;
353 goto next_job;
354 }
355 }
356 }
357
358 if (@SLOT_QUEUE) {
359 # we do not use wait_For_tick() as it returns immediately when tick is inactive
360 push @cf::WAIT_FOR_TICK, $signal;
361 $signal->wait;
362 } else {
363 Coro::schedule;
364 }
365 }
366};
367
368sub get_slot($;$) {
369 my ($time, $pri) = @_;
370
371 push @SLOT_QUEUE, [$time, $pri, my $sig = new Coro::Signal];
372 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
373 $SLOT_QUEUE->ready;
374 $sig->wait;
271} 375}
272 376
273=item cf::async { BLOCK } 377=item cf::async { BLOCK }
274 378
275Currently the same as Coro::async_pool, meaning you cannot use 379Currently the same as Coro::async_pool, meaning you cannot use
280 384
281BEGIN { *async = \&Coro::async_pool } 385BEGIN { *async = \&Coro::async_pool }
282 386
283=item cf::sync_job { BLOCK } 387=item cf::sync_job { BLOCK }
284 388
285The design of crossfire+ requires that the main coro ($Coro::main) is 389The design of Crossfire TRT requires that the main coroutine ($Coro::main)
286always able to handle events or runnable, as crossfire+ is only partly 390is always able to handle events or runnable, as Crossfire TRT is only
287reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 391partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
392acceptable.
288 393
289If it must be done, put the blocking parts into C<sync_job>. This will run 394If it must be done, put the blocking parts into C<sync_job>. This will run
290the given BLOCK in another coroutine while waiting for the result. The 395the given BLOCK in another coroutine while waiting for the result. The
291server will be frozen during this time, so the block should either finish 396server will be frozen during this time, so the block should either finish
292fast or be very important. 397fast or be very important.
295 400
296sub sync_job(&) { 401sub sync_job(&) {
297 my ($job) = @_; 402 my ($job) = @_;
298 403
299 if ($Coro::current == $Coro::main) { 404 if ($Coro::current == $Coro::main) {
405 my $time = Event::time;
406
300 # this is the main coro, too bad, we have to block 407 # this is the main coro, too bad, we have to block
301 # till the operation succeeds, freezing the server :/ 408 # till the operation succeeds, freezing the server :/
302 409
303 # TODO: use suspend/resume instead 410 # TODO: use suspend/resume instead
304 # (but this is cancel-safe) 411 # (but this is cancel-safe)
315 422
316 while ($busy) { 423 while ($busy) {
317 Coro::cede or Event::one_event; 424 Coro::cede or Event::one_event;
318 } 425 }
319 426
427 $time = Event::time - $time;
428
429 LOG llevError | logBacktrace, Carp::longmess "long sync job"
430 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
431
432 $tick_start += $time; # do not account sync jobs to server load
433
320 wantarray ? @res : $res[0] 434 wantarray ? @res : $res[0]
321 } else { 435 } else {
322 # we are in another coroutine, how wonderful, everything just works 436 # we are in another coroutine, how wonderful, everything just works
323 437
324 $job->() 438 $job->()
343 $EXT_CORO{$coro+0} = $coro; 457 $EXT_CORO{$coro+0} = $coro;
344 458
345 $coro 459 $coro
346} 460}
347 461
348sub write_runtime { 462=item fork_call { }, $args
349 my $runtime = cf::localdir . "/runtime";
350 463
351 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 464Executes the given code block with the given arguments in a seperate
352 or return; 465process, returning the results. Everything must be serialisable with
466Coro::Storable. May, of course, block. Note that the executed sub may
467never block itself or use any form of Event handling.
353 468
354 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock 469=cut
355 (aio_write $fh, 0, (length $value), $value, 0) <= 0
356 and return;
357 470
358 aio_fsync $fh 471sub _store_scalar {
359 and return; 472 open my $fh, ">", \my $buf
360 473 or die "fork_call: cannot open fh-to-buf in child : $!";
474 Storable::store_fd $_[0], $fh;
361 close $fh 475 close $fh;
362 or return;
363 476
364 aio_rename "$runtime~", $runtime 477 $buf
365 and return; 478}
366 479
480sub fork_call(&@) {
481 my ($cb, @args) = @_;
482
483# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
484# or die "socketpair: $!";
485 pipe my $fh1, my $fh2
486 or die "pipe: $!";
487
488 if (my $pid = fork) {
489 close $fh2;
490
491 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
492 warn "pst<$res>" unless $res =~ /^pst/;
493 $res = Coro::Storable::thaw $res;
494
495 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
496
497 Carp::confess $$res unless "ARRAY" eq ref $res;
498
499 return wantarray ? @$res : $res->[-1];
500 } else {
501 reset_signals;
502 local $SIG{__WARN__};
503 local $SIG{__DIE__};
504 # just in case, this hack effectively disables event
505 # in the child. cleaner and slower would be canceling all watchers,
506 # but this works for the time being.
507 local $Coro::idle;
508 $Coro::current->prio (Coro::PRIO_MAX);
509
510 eval {
511 close $fh1;
512
513 my @res = eval { $cb->(@args) };
514
515 syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
516 close $fh2;
517 };
518
519 warn $@ if $@;
520 _exit 0;
367 1 521 }
522}
523
524=item $value = cf::db_get $family => $key
525
526Returns a single value from the environment database.
527
528=item cf::db_put $family => $key => $value
529
530Stores the given C<$value> in the family. It can currently store binary
531data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
532
533=cut
534
535our $DB;
536
537sub db_init {
538 unless ($DB) {
539 $DB = BDB::db_create $DB_ENV;
540
541 cf::sync_job {
542 eval {
543 $DB->set_flags (BDB::CHKSUM);
544
545 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
546 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
547 cf::cleanup "db_open(db): $!" if $!;
548 };
549 cf::cleanup "db_open(db): $@" if $@;
550 };
551 }
552}
553
554sub db_get($$) {
555 my $key = "$_[0]/$_[1]";
556
557 cf::sync_job {
558 BDB::db_get $DB, undef, $key, my $data;
559
560 $! ? ()
561 : $data
562 }
563}
564
565sub db_put($$$) {
566 BDB::dbreq_pri 4;
567 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
568}
569
570=item cf::cache $id => [$paths...], $processversion => $process
571
572Generic caching function that returns the value of the resource $id,
573caching and regenerating as required.
574
575This function can block.
576
577=cut
578
579sub cache {
580 my ($id, $src, $processversion, $process) = @_;
581
582 my $meta =
583 join "\x00",
584 $processversion,
585 map {
586 aio_stat $_
587 and Carp::croak "$_: $!";
588
589 ($_, (stat _)[7,9])
590 } @$src;
591
592 my $dbmeta = db_get cache => "$id/meta";
593 if ($dbmeta ne $meta) {
594 # changed, we may need to process
595
596 my @data;
597 my $md5;
598
599 for (0 .. $#$src) {
600 0 <= aio_load $src->[$_], $data[$_]
601 or Carp::croak "$src->[$_]: $!";
602 }
603
604 # if processing is expensive, check
605 # checksum first
606 if (1) {
607 $md5 =
608 join "\x00",
609 $processversion,
610 map {
611 Coro::cede;
612 ($src->[$_], Digest::MD5::md5_hex $data[$_])
613 } 0.. $#$src;
614
615
616 my $dbmd5 = db_get cache => "$id/md5";
617 if ($dbmd5 eq $md5) {
618 db_put cache => "$id/meta", $meta;
619
620 return db_get cache => "$id/data";
621 }
622 }
623
624 my $t1 = Time::HiRes::time;
625 my $data = $process->(\@data);
626 my $t2 = Time::HiRes::time;
627
628 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
629
630 db_put cache => "$id/data", $data;
631 db_put cache => "$id/md5" , $md5;
632 db_put cache => "$id/meta", $meta;
633
634 return $data;
635 }
636
637 db_get cache => "$id/data"
638}
639
640=item cf::datalog type => key => value, ...
641
642Log a datalog packet of the given type with the given key-value pairs.
643
644=cut
645
646sub datalog($@) {
647 my ($type, %kv) = @_;
648 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
368} 649}
369 650
370=back 651=back
371 652
372=cut 653=cut
379attach callbacks/event handlers (a collection of which is called an "attachment") 660attach callbacks/event handlers (a collection of which is called an "attachment")
380to it. All such attachable objects support the following methods. 661to it. All such attachable objects support the following methods.
381 662
382In the following description, CLASS can be any of C<global>, C<object> 663In the following description, CLASS can be any of C<global>, C<object>
383C<player>, C<client> or C<map> (i.e. the attachable objects in 664C<player>, C<client> or C<map> (i.e. the attachable objects in
384crossfire+). 665Crossfire TRT).
385 666
386=over 4 667=over 4
387 668
388=item $attachable->attach ($attachment, key => $value...) 669=item $attachable->attach ($attachment, key => $value...)
389 670
552 $registry = $CB_TYPE[$object_type] ||= []; 833 $registry = $CB_TYPE[$object_type] ||= [];
553 834
554 } elsif ($type eq "subtype") { 835 } elsif ($type eq "subtype") {
555 defined $object_type or Carp::croak "subtype specified without type"; 836 defined $object_type or Carp::croak "subtype specified without type";
556 my $object_subtype = shift @arg; 837 my $object_subtype = shift @arg;
557 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 838 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
558 839
559 } elsif ($type eq "package") { 840 } elsif ($type eq "package") {
560 my $pkg = shift @arg; 841 my $pkg = shift @arg;
561 842
562 while (my ($name, $id) = each %cb_id) { 843 while (my ($name, $id) = each %cb_id) {
591 _attach $registry, $klass, @attach; 872 _attach $registry, $klass, @attach;
592 } 873 }
593 874
594 $obj->{$name} = \%arg; 875 $obj->{$name} = \%arg;
595 } else { 876 } else {
596 warn "object uses attachment '$name' that is not available, postponing.\n"; 877 warn "object uses attachment '$name' which is not available, postponing.\n";
597 } 878 }
598 879
599 $obj->{_attachment}{$name} = undef; 880 $obj->{_attachment}{$name} = undef;
600} 881}
601 882
603 if (ref $_[0]) { 884 if (ref $_[0]) {
604 _object_attach @_; 885 _object_attach @_;
605 } else { 886 } else {
606 _attach shift->_attach_registry, @_; 887 _attach shift->_attach_registry, @_;
607 } 888 }
889 _recalc_want;
608}; 890};
609 891
610# all those should be optimised 892# all those should be optimised
611sub cf::attachable::detach { 893sub cf::attachable::detach {
612 my ($obj, $name) = @_; 894 my ($obj, $name) = @_;
615 delete $obj->{_attachment}{$name}; 897 delete $obj->{_attachment}{$name};
616 reattach ($obj); 898 reattach ($obj);
617 } else { 899 } else {
618 Carp::croak "cannot, currently, detach class attachments"; 900 Carp::croak "cannot, currently, detach class attachments";
619 } 901 }
902 _recalc_want;
620}; 903};
621 904
622sub cf::attachable::attached { 905sub cf::attachable::attached {
623 my ($obj, $name) = @_; 906 my ($obj, $name) = @_;
624 907
639 "; 922 ";
640 die if $@; 923 die if $@;
641} 924}
642 925
643our $override; 926our $override;
644our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 927our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
645 928
646sub override { 929sub override {
647 $override = 1; 930 $override = 1;
648 @invoke_results = (); 931 @INVOKE_RESULTS = (@_);
649} 932}
650 933
651sub do_invoke { 934sub do_invoke {
652 my $event = shift; 935 my $event = shift;
653 my $callbacks = shift; 936 my $callbacks = shift;
654 937
655 @invoke_results = (); 938 @INVOKE_RESULTS = ();
656 939
657 local $override; 940 local $override;
658 941
659 for (@$callbacks) { 942 for (@$callbacks) {
660 eval { &{$_->[1]} }; 943 eval { &{$_->[1]} };
677 960
678Generate an object-specific event with the given arguments. 961Generate an object-specific event with the given arguments.
679 962
680This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 963This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
681removed in future versions), and there is no public API to access override 964removed in future versions), and there is no public API to access override
682results (if you must, access C<@cf::invoke_results> directly). 965results (if you must, access C<@cf::INVOKE_RESULTS> directly).
683 966
684=back 967=back
685 968
686=cut 969=cut
687 970
688############################################################################# 971#############################################################################
689# object support 972# object support
973#
974
975sub _can_merge {
976 my ($ob1, $ob2) = @_;
977
978 local $Storable::canonical = 1;
979 my $fob1 = Storable::freeze $ob1;
980 my $fob2 = Storable::freeze $ob2;
981
982 $fob1 eq $fob2
983}
690 984
691sub reattach { 985sub reattach {
692 # basically do the same as instantiate, without calling instantiate 986 # basically do the same as instantiate, without calling instantiate
693 my ($obj) = @_; 987 my ($obj) = @_;
694 988
747 $filename, length $$rdata, scalar @$objs; 1041 $filename, length $$rdata, scalar @$objs;
748 1042
749 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1043 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
750 chmod SAVE_MODE, $fh; 1044 chmod SAVE_MODE, $fh;
751 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1045 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
752 aio_fsync $fh; 1046 aio_fsync $fh if $cf::USE_FSYNC;
753 close $fh; 1047 close $fh;
754 1048
755 if (@$objs) { 1049 if (@$objs) {
756 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1050 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
757 chmod SAVE_MODE, $fh; 1051 chmod SAVE_MODE, $fh;
758 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1052 my $data = Storable::nfreeze { version => 1, objs => $objs };
759 aio_write $fh, 0, (length $data), $data, 0; 1053 aio_write $fh, 0, (length $data), $data, 0;
760 aio_fsync $fh; 1054 aio_fsync $fh if $cf::USE_FSYNC;
761 close $fh; 1055 close $fh;
762 aio_rename "$filename.pst~", "$filename.pst"; 1056 aio_rename "$filename.pst~", "$filename.pst";
763 } 1057 }
764 } else { 1058 } else {
765 aio_unlink "$filename.pst"; 1059 aio_unlink "$filename.pst";
797 or return; 1091 or return;
798 $av = eval { (Storable::thaw $av)->{objs} }; 1092 $av = eval { (Storable::thaw $av)->{objs} };
799 } 1093 }
800 1094
801 warn sprintf "loading %s (%d)\n", 1095 warn sprintf "loading %s (%d)\n",
802 $filename, length $data, scalar @{$av || []};#d# 1096 $filename, length $data, scalar @{$av || []};
803 return ($data, $av); 1097 return ($data, $av);
804} 1098}
1099
1100=head2 COMMAND CALLBACKS
1101
1102=over 4
1103
1104=cut
805 1105
806############################################################################# 1106#############################################################################
807# command handling &c 1107# command handling &c
808 1108
809=item cf::register_command $name => \&callback($ob,$args); 1109=item cf::register_command $name => \&callback($ob,$args);
822 push @{ $COMMAND{$name} }, [$caller, $cb]; 1122 push @{ $COMMAND{$name} }, [$caller, $cb];
823} 1123}
824 1124
825=item cf::register_extcmd $name => \&callback($pl,$packet); 1125=item cf::register_extcmd $name => \&callback($pl,$packet);
826 1126
827Register a callbackf ro execution when the client sends an extcmd packet. 1127Register a callback for execution when the client sends an (synchronous)
1128extcmd packet. Ext commands will be processed in the order they are
1129received by the server, like other user commands. The first argument is
1130the logged-in player. Ext commands can only be processed after a player
1131has logged in successfully.
828 1132
829If the callback returns something, it is sent back as if reply was being 1133If the callback returns something, it is sent back as if reply was being
830called. 1134called.
831 1135
1136=item cf::register_exticmd $name => \&callback($ns,$packet);
1137
1138Register a callback for execution when the client sends an (asynchronous)
1139exticmd packet. Exti commands are processed by the server as soon as they
1140are received, i.e. out of order w.r.t. other commands. The first argument
1141is a client socket. Exti commands can be received anytime, even before
1142log-in.
1143
1144If the callback returns something, it is sent back as if reply was being
1145called.
1146
832=cut 1147=cut
833 1148
834sub register_extcmd { 1149sub register_extcmd {
835 my ($name, $cb) = @_; 1150 my ($name, $cb) = @_;
836 1151
837 $EXTCMD{$name} = $cb; 1152 $EXTCMD{$name} = $cb;
1153}
1154
1155sub register_exticmd {
1156 my ($name, $cb) = @_;
1157
1158 $EXTICMD{$name} = $cb;
838} 1159}
839 1160
840cf::player->attach ( 1161cf::player->attach (
841 on_command => sub { 1162 on_command => sub {
842 my ($pl, $name, $params) = @_; 1163 my ($pl, $name, $params) = @_;
851 cf::override; 1172 cf::override;
852 }, 1173 },
853 on_extcmd => sub { 1174 on_extcmd => sub {
854 my ($pl, $buf) = @_; 1175 my ($pl, $buf) = @_;
855 1176
856 my $msg = eval { from_json $buf }; 1177 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
857 1178
858 if (ref $msg) { 1179 if (ref $msg) {
859 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1180 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
860 if (my %reply = $cb->($pl, $msg)) { 1181 if (my %reply = $cb->($pl, $msg)) {
861 $pl->ext_reply ($msg->{msgid}, %reply); 1182 $pl->ext_reply ($msg->{msgid}, %reply);
867 1188
868 cf::override; 1189 cf::override;
869 }, 1190 },
870); 1191);
871 1192
872sub load_extension {
873 my ($path) = @_;
874
875 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
876 my $base = $1;
877 my $pkg = $1;
878 $pkg =~ s/[^[:word:]]/_/g;
879 $pkg = "ext::$pkg";
880
881 warn "... loading '$path' into '$pkg'\n";
882
883 open my $fh, "<:utf8", $path
884 or die "$path: $!";
885
886 my $source =
887 "package $pkg; use strict; use utf8;\n"
888 . "#line 1 \"$path\"\n{\n"
889 . (do { local $/; <$fh> })
890 . "\n};\n1";
891
892 unless (eval $source) {
893 my $msg = $@ ? "$path: $@\n"
894 : "extension disabled.\n";
895 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
896 warn $@;
897 warn "mandatory extension failed to load, exiting.\n";
898 exit 1;
899 }
900 die $@;
901 }
902
903 push @EXTS, $pkg;
904}
905
906sub load_extensions { 1193sub load_extensions {
1194 cf::sync_job {
1195 my %todo;
1196
907 for my $ext (<$LIBDIR/*.ext>) { 1197 for my $path (<$LIBDIR/*.ext>) {
908 next unless -r $ext; 1198 next unless -r $path;
909 eval { 1199
910 load_extension $ext; 1200 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1201 my $base = $1;
1202 my $pkg = $1;
1203 $pkg =~ s/[^[:word:]]/_/g;
1204 $pkg = "ext::$pkg";
1205
1206 open my $fh, "<:utf8", $path
1207 or die "$path: $!";
1208
1209 my $source = do { local $/; <$fh> };
1210
1211 my %ext = (
1212 path => $path,
1213 base => $base,
1214 pkg => $pkg,
1215 );
1216
1217 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1218 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1219
1220 $ext{source} =
1221 "package $pkg; use strict; use utf8;\n"
1222 . "#line 1 \"$path\"\n{\n"
1223 . $source
1224 . "\n};\n1";
1225
1226 $todo{$base} = \%ext;
1227 }
1228
1229 my %done;
1230 while (%todo) {
1231 my $progress;
1232
1233 while (my ($k, $v) = each %todo) {
1234 for (split /,\s*/, $v->{meta}{depends}) {
1235 goto skip
1236 unless exists $done{$_};
1237 }
1238
1239 warn "... loading '$k' into '$v->{pkg}'\n";
1240
1241 unless (eval $v->{source}) {
1242 my $msg = $@ ? "$v->{path}: $@\n"
1243 : "$v->{base}: extension inactive.\n";
1244
1245 if (exists $v->{meta}{mandatory}) {
1246 warn $msg;
1247 warn "mandatory extension failed to load, exiting.\n";
1248 exit 1;
1249 }
1250
1251 warn $msg;
1252 }
1253
1254 $done{$k} = delete $todo{$k};
1255 push @EXTS, $v->{pkg};
1256 $progress = 1;
911 1 1257 }
912 } or warn "$ext not loaded: $@"; 1258
1259 skip:
1260 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1261 unless $progress;
1262 }
913 } 1263 };
914} 1264}
915 1265
916############################################################################# 1266#############################################################################
917 1267
1268=back
1269
918=head2 CORE EXTENSIONS 1270=head2 CORE EXTENSIONS
919 1271
920Functions and methods that extend core crossfire objects. 1272Functions and methods that extend core crossfire objects.
921 1273
922=cut 1274=cut
934Returns the given player object, loading it if necessary (might block). 1286Returns the given player object, loading it if necessary (might block).
935 1287
936=cut 1288=cut
937 1289
938sub playerdir($) { 1290sub playerdir($) {
939 cf::localdir 1291 "$PLAYERDIR/"
940 . "/"
941 . cf::playerdir
942 . "/"
943 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1292 . (ref $_[0] ? $_[0]->ob->name : $_[0])
944} 1293}
945 1294
946sub path($) { 1295sub path($) {
947 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1296 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
948 1297
949 (playerdir $login) . "/$login.pl" 1298 (playerdir $login) . "/playerdata"
950} 1299}
951 1300
952sub find_active($) { 1301sub find_active($) {
953 $cf::PLAYER{$_[0]} 1302 $cf::PLAYER{$_[0]}
954 and $cf::PLAYER{$_[0]}->active 1303 and $cf::PLAYER{$_[0]}->active
967 my $login = $_[0]; 1316 my $login = $_[0];
968 1317
969 my $guard = cf::lock_acquire "user_find:$login"; 1318 my $guard = cf::lock_acquire "user_find:$login";
970 1319
971 $cf::PLAYER{$_[0]} || do { 1320 $cf::PLAYER{$_[0]} || do {
1321 # rename old playerfiles to new ones
1322 #TODO: remove when no longer required
1323 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1324 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1325 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1326 aio_unlink +(playerdir $login) . "/$login.pl";
1327
972 my $pl = load_pl path $login 1328 my $pl = load_pl path $login
973 or return; 1329 or return;
974 $cf::PLAYER{$login} = $pl 1330 $cf::PLAYER{$login} = $pl
975 } 1331 }
976 } 1332 }
1013 1369
1014=cut 1370=cut
1015 1371
1016sub quit_character { 1372sub quit_character {
1017 my ($pl) = @_; 1373 my ($pl) = @_;
1374
1375 my $name = $pl->ob->name;
1018 1376
1019 $pl->{deny_save} = 1; 1377 $pl->{deny_save} = 1;
1020 $pl->password ("*"); # this should lock out the player until we nuked the dir 1378 $pl->password ("*"); # this should lock out the player until we nuked the dir
1021 1379
1022 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1380 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1027 my $path = playerdir $pl; 1385 my $path = playerdir $pl;
1028 my $temp = "$path~$cf::RUNTIME~deleting~"; 1386 my $temp = "$path~$cf::RUNTIME~deleting~";
1029 aio_rename $path, $temp; 1387 aio_rename $path, $temp;
1030 delete $cf::PLAYER{$pl->ob->name}; 1388 delete $cf::PLAYER{$pl->ob->name};
1031 $pl->destroy; 1389 $pl->destroy;
1390
1391 my $prefix = qr<^~\Q$name\E/>;
1392
1393 # nuke player maps
1394 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1395
1032 IO::AIO::aio_rmtree $temp; 1396 IO::AIO::aio_rmtree $temp;
1397}
1398
1399=item $pl->kick
1400
1401Kicks a player out of the game. This destroys the connection.
1402
1403=cut
1404
1405sub kick {
1406 my ($pl, $kicker) = @_;
1407
1408 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1409 $pl->killer ("kicked");
1410 $pl->ns->destroy;
1033} 1411}
1034 1412
1035=item cf::player::list_logins 1413=item cf::player::list_logins
1036 1414
1037Returns am arrayref of all valid playernames in the system, can take a 1415Returns am arrayref of all valid playernames in the system, can take a
1038while and may block, so not sync_job-capable, ever. 1416while and may block, so not sync_job-capable, ever.
1039 1417
1040=cut 1418=cut
1041 1419
1042sub list_logins { 1420sub list_logins {
1043 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1421 my $dirs = aio_readdir $PLAYERDIR
1044 or return []; 1422 or return [];
1045 1423
1046 my @logins; 1424 my @logins;
1047 1425
1048 for my $login (@$dirs) { 1426 for my $login (@$dirs) {
1065=cut 1443=cut
1066 1444
1067sub maps($) { 1445sub maps($) {
1068 my ($pl) = @_; 1446 my ($pl) = @_;
1069 1447
1448 $pl = ref $pl ? $pl->ob->name : $pl;
1449
1070 my $files = aio_readdir playerdir $pl 1450 my $files = aio_readdir playerdir $pl
1071 or return; 1451 or return;
1072 1452
1073 my @paths; 1453 my @paths;
1074 1454
1075 for (@$files) { 1455 for (@$files) {
1076 utf8::decode $_; 1456 utf8::decode $_;
1077 next if /\.(?:pl|pst)$/; 1457 next if /\.(?:pl|pst)$/;
1078 next unless /^$PATH_SEP/o; 1458 next unless /^$PATH_SEP/o;
1079 1459
1080 s/\.map$//; 1460 push @paths, cf::map::normalise "~$pl/$_";
1081 push @paths, "~" . $pl->ob->name . "/" . $_;
1082 } 1461 }
1083 1462
1084 \@paths 1463 \@paths
1085} 1464}
1086 1465
1466=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1467
1468Expand crossfire pod fragments into protocol xml.
1469
1470=cut
1471
1472sub expand_cfpod {
1473 ((my $self), (local $_)) = @_;
1474
1475 # escape & and <
1476 s/&/&amp;/g;
1477 s/(?<![BIUGH])</&lt;/g;
1478
1479 # this is buggy, it needs to properly take care of nested <'s
1480
1481 1 while
1482 # replace B<>, I<>, U<> etc.
1483 s/B<([^\>]*)>/<b>$1<\/b>/
1484 || s/I<([^\>]*)>/<i>$1<\/i>/
1485 || s/U<([^\>]*)>/<u>$1<\/u>/
1486 # replace G<male|female> tags
1487 || s{G<([^>|]*)\|([^>]*)>}{
1488 $self->gender ? $2 : $1
1489 }ge
1490 # replace H<hint text>
1491 || s{H<([^\>]*)>}
1492 {
1493 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1494 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1495 "")
1496 [$self->{hintmode}]
1497 }ge;
1498
1499 # create single paragraphs (very hackish)
1500 s/(?<=\S)\n(?=\w)/ /g;
1501
1502 # compress some whitespace
1503 s/\s+\n/\n/g; # ws line-ends
1504 s/\n\n+/\n/g; # double lines
1505 s/^\n+//; # beginning lines
1506 s/\n+$//; # ending lines
1507
1508 $_
1509}
1510
1511sub hintmode {
1512 $_[0]{hintmode} = $_[1] if @_ > 1;
1513 $_[0]{hintmode}
1514}
1515
1087=item $player->ext_reply ($msgid, $msgtype, %msg) 1516=item $player->ext_reply ($msgid, %msg)
1088 1517
1089Sends an ext reply to the player. 1518Sends an ext reply to the player.
1090 1519
1091=cut 1520=cut
1092 1521
1093sub ext_reply($$$%) { 1522sub ext_reply($$%) {
1094 my ($self, $id, %msg) = @_; 1523 my ($self, $id, %msg) = @_;
1095 1524
1096 $msg{msgid} = $id; 1525 $msg{msgid} = $id;
1097 1526 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1098 $self->send ("ext " . cf::to_json \%msg);
1099} 1527}
1100 1528
1101package cf; 1529=item $player->ext_event ($type, %msg)
1530
1531Sends an ext event to the client.
1532
1533=cut
1534
1535sub ext_event($$%) {
1536 my ($self, $type, %msg) = @_;
1537
1538 $self->ns->ext_event ($type, %msg);
1539}
1540
1541=head3 cf::region
1542
1543=over 4
1544
1545=cut
1546
1547package cf::region;
1548
1549=item cf::region::find_by_path $path
1550
1551Tries to decuce the likely region for a map knowing only its path.
1552
1553=cut
1554
1555sub find_by_path($) {
1556 my ($path) = @_;
1557
1558 my ($match, $specificity);
1559
1560 for my $region (list) {
1561 if ($region->{match} && $path =~ $region->{match}) {
1562 ($match, $specificity) = ($region, $region->specificity)
1563 if $region->specificity > $specificity;
1564 }
1565 }
1566
1567 $match
1568}
1102 1569
1103=back 1570=back
1104
1105 1571
1106=head3 cf::map 1572=head3 cf::map
1107 1573
1108=over 4 1574=over 4
1109 1575
1137 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1603 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1138 (cf::region::find $rmp->{region}), $rmp->{custom} 1604 (cf::region::find $rmp->{region}), $rmp->{custom}
1139 ) 1605 )
1140} 1606}
1141 1607
1608=item cf::map->register ($regex, $prio)
1609
1610Register a handler for the map path matching the given regex at the
1611givne priority (higher is better, built-in handlers have priority 0, the
1612default).
1613
1614=cut
1615
1142sub register { 1616sub register {
1143 my (undef, $regex) = @_; 1617 my (undef, $regex, $prio) = @_;
1144 my $pkg = caller; 1618 my $pkg = caller;
1145 1619
1146 no strict; 1620 no strict;
1147 push @{"$pkg\::ISA"}, __PACKAGE__; 1621 push @{"$pkg\::ISA"}, __PACKAGE__;
1148 1622
1149 $EXT_MAP{$pkg} = qr<$regex>; 1623 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1150} 1624}
1151 1625
1152# also paths starting with '/' 1626# also paths starting with '/'
1153$EXT_MAP{"cf::map"} = qr{^(?=/)}; 1627$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1154 1628
1155sub thawer_merge { 1629sub thawer_merge {
1156 my ($self, $merge) = @_; 1630 my ($self, $merge) = @_;
1157 1631
1158 # we have to keep some variables in memory intact 1632 # we have to keep some variables in memory intact
1159 local $self->{path}; 1633 local $self->{path};
1160 local $self->{load_path}; 1634 local $self->{load_path};
1161 local $self->{deny_save};
1162 local $self->{deny_reset};
1163 1635
1164 $self->SUPER::thawer_merge ($merge); 1636 $self->SUPER::thawer_merge ($merge);
1165} 1637}
1166 1638
1167sub normalise { 1639sub normalise {
1168 my ($path, $base) = @_; 1640 my ($path, $base) = @_;
1641
1642 $path = "$path"; # make sure its a string
1643
1644 $path =~ s/\.map$//;
1169 1645
1170 # map plan: 1646 # map plan:
1171 # 1647 #
1172 # /! non-realised random map exit (special hack!) 1648 # /! non-realised random map exit (special hack!)
1173 # {... are special paths that are not being touched 1649 # {... are special paths that are not being touched
1201 1677
1202 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object 1678 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1203 1679
1204 $path = normalise $path, $base; 1680 $path = normalise $path, $base;
1205 1681
1206 for my $pkg (keys %EXT_MAP) { 1682 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1207 if ($path =~ $EXT_MAP{$pkg}) { 1683 if ($path =~ $EXT_MAP{$pkg}[1]) {
1208 my $self = bless cf::map::new, $pkg; 1684 my $self = bless cf::map::new, $pkg;
1209 $self->{path} = $path; $self->path ($path); 1685 $self->{path} = $path; $self->path ($path);
1210 $self->init; # pass $1 etc. 1686 $self->init; # pass $1 etc.
1211 return $self; 1687 return $self;
1212 } 1688 }
1213 } 1689 }
1214 1690
1215 Carp::carp "unable to resolve path '$path'."; 1691 Carp::cluck "unable to resolve path '$path' (base '$base').";
1216 () 1692 ()
1217} 1693}
1218 1694
1219sub init { 1695sub init {
1220 my ($self) = @_; 1696 my ($self) = @_;
1235 1711
1236# the original (read-only) location 1712# the original (read-only) location
1237sub load_path { 1713sub load_path {
1238 my ($self) = @_; 1714 my ($self) = @_;
1239 1715
1240 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path} 1716 "$MAPDIR/$self->{path}.map"
1241} 1717}
1242 1718
1243# the temporary/swap location 1719# the temporary/swap location
1244sub save_path { 1720sub save_path {
1245 my ($self) = @_; 1721 my ($self) = @_;
1246 1722
1247 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1723 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1248 sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $path 1724 "$TMPDIR/$path.map"
1249} 1725}
1250 1726
1251# the unique path, undef == no special unique path 1727# the unique path, undef == no special unique path
1252sub uniq_path { 1728sub uniq_path {
1253 my ($self) = @_; 1729 my ($self) = @_;
1254 1730
1255 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1731 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1256 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1732 "$UNIQUEDIR/$path"
1257} 1733}
1258 1734
1259# and all this just because we cannot iterate over 1735# and all this just because we cannot iterate over
1260# all maps in C++... 1736# all maps in C++...
1261sub change_all_map_light { 1737sub change_all_map_light {
1263 1739
1264 $_->change_map_light ($change) 1740 $_->change_map_light ($change)
1265 for grep $_->outdoor, values %cf::MAP; 1741 for grep $_->outdoor, values %cf::MAP;
1266} 1742}
1267 1743
1744sub decay_objects {
1745 my ($self) = @_;
1746
1747 return if $self->{deny_reset};
1748
1749 $self->do_decay_objects;
1750}
1751
1268sub unlink_save { 1752sub unlink_save {
1269 my ($self) = @_; 1753 my ($self) = @_;
1270 1754
1271 utf8::encode (my $save = $self->save_path); 1755 utf8::encode (my $save = $self->save_path);
1272 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1756 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1275 1759
1276sub load_header_from($) { 1760sub load_header_from($) {
1277 my ($self, $path) = @_; 1761 my ($self, $path) = @_;
1278 1762
1279 utf8::encode $path; 1763 utf8::encode $path;
1280 aio_open $path, O_RDONLY, 0 1764 #aio_open $path, O_RDONLY, 0
1281 or return; 1765 # or return;
1282 1766
1283 $self->_load_header ($path) 1767 $self->_load_header ($path)
1284 or return; 1768 or return;
1285 1769
1286 $self->{load_path} = $path; 1770 $self->{load_path} = $path;
1287 1771
1288 1 1772 1
1289} 1773}
1290 1774
1291sub load_orig { 1775sub load_header_orig {
1292 my ($self) = @_; 1776 my ($self) = @_;
1293 1777
1294 $self->load_header_from ($self->load_path) 1778 $self->load_header_from ($self->load_path)
1295} 1779}
1296 1780
1297sub load_temp { 1781sub load_header_temp {
1298 my ($self) = @_; 1782 my ($self) = @_;
1299 1783
1300 $self->load_header_from ($self->save_path) 1784 $self->load_header_from ($self->save_path)
1785}
1786
1787sub prepare_temp {
1788 my ($self) = @_;
1789
1790 $self->last_access ((delete $self->{last_access})
1791 || $cf::RUNTIME); #d#
1792 # safety
1793 $self->{instantiate_time} = $cf::RUNTIME
1794 if $self->{instantiate_time} > $cf::RUNTIME;
1795}
1796
1797sub prepare_orig {
1798 my ($self) = @_;
1799
1800 $self->{load_original} = 1;
1801 $self->{instantiate_time} = $cf::RUNTIME;
1802 $self->last_access ($cf::RUNTIME);
1803 $self->instantiate;
1301} 1804}
1302 1805
1303sub load_header { 1806sub load_header {
1304 my ($self) = @_; 1807 my ($self) = @_;
1305 1808
1306 if ($self->load_temp) { 1809 if ($self->load_header_temp) {
1307 $self->last_access ((delete $self->{last_access}) 1810 $self->prepare_temp;
1308 || $cf::RUNTIME); #d#
1309 # safety
1310 $self->{instantiate_time} = $cf::RUNTIME
1311 if $self->{instantiate_time} > $cf::RUNTIME;
1312 } else { 1811 } else {
1313 $self->load_orig 1812 $self->load_header_orig
1314 or return; 1813 or return;
1315 1814 $self->prepare_orig;
1316 $self->{load_original} = 1;
1317 $self->{instantiate_time} = $cf::RUNTIME;
1318 $self->last_access ($cf::RUNTIME);
1319 $self->instantiate;
1320 } 1815 }
1816
1817 $self->{deny_reset} = 1
1818 if $self->no_reset;
1819
1820 $self->default_region (cf::region::find_by_path $self->{path})
1821 unless $self->default_region;
1321 1822
1322 1 1823 1
1323} 1824}
1324 1825
1325sub find; 1826sub find;
1338 $map->{last_save} = $cf::RUNTIME; 1839 $map->{last_save} = $cf::RUNTIME;
1339 1840
1340 $map->load_header 1841 $map->load_header
1341 or return; 1842 or return;
1342 1843
1343 if ($map->should_reset) { 1844 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1845 # doing this can freeze the server in a sync job, obviously
1344 $cf::WAIT_FOR_TICK->wait; 1846 #$cf::WAIT_FOR_TICK->wait;
1345 $map->reset; 1847 $map->reset;
1346 undef $guard; 1848 undef $guard;
1347 $map = find $path 1849 return find $path;
1348 or return;
1349 } 1850 }
1350 1851
1351 $cf::MAP{$path} = $map 1852 $cf::MAP{$path} = $map
1352 } 1853 }
1353} 1854}
1855
1856sub pre_load { }
1857sub post_load { }
1354 1858
1355sub load { 1859sub load {
1356 my ($self) = @_; 1860 my ($self) = @_;
1357 1861
1862 local $self->{deny_reset} = 1; # loading can take a long time
1863
1358 my $path = $self->{path}; 1864 my $path = $self->{path};
1865
1866 {
1359 my $guard = cf::lock_acquire "map_load:$path"; 1867 my $guard = cf::lock_acquire "map_load:$path";
1360 1868
1361 return if $self->in_memory != cf::MAP_SWAPPED; 1869 return if $self->in_memory != cf::MAP_SWAPPED;
1362 1870
1363 $self->in_memory (cf::MAP_LOADING); 1871 $self->in_memory (cf::MAP_LOADING);
1364 1872
1365 $self->alloc; 1873 $self->alloc;
1366 $self->_load_objects ($self->{load_path}, 1)
1367 or return;
1368 1874
1369 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1875 $self->pre_load;
1370 if delete $self->{load_original};
1371
1372 if (my $uniq = $self->uniq_path) {
1373 utf8::encode $uniq;
1374 if (aio_open $uniq, O_RDONLY, 0) {
1375 $self->clear_unique_items;
1376 $self->_load_objects ($uniq, 0);
1377 }
1378 }
1379
1380 Coro::cede;
1381
1382 # now do the right thing for maps
1383 $self->link_multipart_objects;
1384
1385 unless ($self->{deny_activate}) {
1386 $self->decay_objects;
1387 $self->fix_auto_apply;
1388 $self->update_buttons;
1389 Coro::cede; 1876 Coro::cede;
1390 $self->set_darkness_map; 1877
1878 $self->_load_objects ($self->{load_path}, 1)
1879 or return;
1880
1881 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1882 if delete $self->{load_original};
1883
1884 if (my $uniq = $self->uniq_path) {
1885 utf8::encode $uniq;
1886 if (aio_open $uniq, O_RDONLY, 0) {
1887 $self->clear_unique_items;
1888 $self->_load_objects ($uniq, 0);
1889 }
1890 }
1891
1892 Coro::cede;
1893 # now do the right thing for maps
1894 $self->link_multipart_objects;
1391 $self->difficulty ($self->estimate_difficulty) 1895 $self->difficulty ($self->estimate_difficulty)
1392 unless $self->difficulty; 1896 unless $self->difficulty;
1393 Coro::cede; 1897 Coro::cede;
1898
1899 unless ($self->{deny_activate}) {
1900 $self->decay_objects;
1901 $self->fix_auto_apply;
1902 $self->update_buttons;
1903 Coro::cede;
1904 $self->set_darkness_map;
1905 Coro::cede;
1394 $self->activate; 1906 $self->activate;
1395 } 1907 }
1396 1908
1397 $self->in_memory (cf::MAP_IN_MEMORY); 1909 $self->in_memory (cf::MAP_IN_MEMORY);
1910 }
1911
1912 $self->post_load;
1398} 1913}
1399 1914
1400sub customise_for { 1915sub customise_for {
1401 my ($self, $ob) = @_; 1916 my ($self, $ob) = @_;
1402 1917
1403 return find "~" . $ob->name . "/" . $self->{path} 1918 return find "~" . $ob->name . "/" . $self->{path}
1404 if $self->per_player; 1919 if $self->per_player;
1920
1921# return find "?party/" . $ob->name . "/" . $self->{path}
1922# if $self->per_party;
1405 1923
1406 $self 1924 $self
1407} 1925}
1408 1926
1409# find and load all maps in the 3x3 area around a map 1927# find and load all maps in the 3x3 area around a map
1456 1974
1457 undef $MAP_PREFETCH{$path}; 1975 undef $MAP_PREFETCH{$path};
1458 $MAP_PREFETCHER ||= cf::async { 1976 $MAP_PREFETCHER ||= cf::async {
1459 while (%MAP_PREFETCH) { 1977 while (%MAP_PREFETCH) {
1460 for my $path (keys %MAP_PREFETCH) { 1978 for my $path (keys %MAP_PREFETCH) {
1461 warn "prefetching $path...\n";#d#
1462 my $map = find $path 1979 if (my $map = find $path) {
1463 or next;
1464 $map->load; 1980 $map->load;
1981 }
1465 1982
1466 delete $MAP_PREFETCH{$path}; 1983 delete $MAP_PREFETCH{$path};
1467 } 1984 }
1468 } 1985 }
1469 undef $MAP_PREFETCHER; 1986 undef $MAP_PREFETCHER;
1470 }; 1987 };
1988 $MAP_PREFETCHER->prio (6);
1471 1989
1472 () 1990 ()
1473} 1991}
1474 1992
1475sub save { 1993sub save {
1520 2038
1521sub reset_at { 2039sub reset_at {
1522 my ($self) = @_; 2040 my ($self) = @_;
1523 2041
1524 # TODO: safety, remove and allow resettable per-player maps 2042 # TODO: safety, remove and allow resettable per-player maps
1525 return 1e99 if $self->isa ("ext::map_per_player");#d#
1526 return 1e99 if $self->{deny_reset}; 2043 return 1e99 if $self->{deny_reset};
1527 2044
1528 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2045 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1529 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2046 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1530 2047
1541 my ($self) = @_; 2058 my ($self) = @_;
1542 2059
1543 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2060 my $lock = cf::lock_acquire "map_data:$self->{path}";
1544 2061
1545 return if $self->players; 2062 return if $self->players;
1546 return if $self->isa ("ext::map_per_player");#d#
1547 2063
1548 warn "resetting map ", $self->path;#d# 2064 warn "resetting map ", $self->path;
2065
2066 $self->in_memory (cf::MAP_SWAPPED);
2067
2068 # need to save uniques path
2069 unless ($self->{deny_save}) {
2070 my $uniq = $self->uniq_path; utf8::encode $uniq;
2071
2072 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2073 if $uniq;
2074 }
1549 2075
1550 delete $cf::MAP{$self->path}; 2076 delete $cf::MAP{$self->path};
1551 2077
1552 $self->in_memory (cf::MAP_SWAPPED);
1553 $self->clear; 2078 $self->clear;
1554 2079
1555 $_->clear_links_to ($self) for values %cf::MAP; 2080 $_->clear_links_to ($self) for values %cf::MAP;
1556 2081
1557 $self->unlink_save; 2082 $self->unlink_save;
1576 $cf::MAP{$self->path} = $self; 2101 $cf::MAP{$self->path} = $self;
1577 2102
1578 $self->reset; # polite request, might not happen 2103 $self->reset; # polite request, might not happen
1579} 2104}
1580 2105
2106=item $maps = cf::map::tmp_maps
2107
2108Returns an arrayref with all map paths of currently instantiated and saved
2109maps. May block.
2110
2111=cut
2112
2113sub tmp_maps() {
2114 [
2115 map {
2116 utf8::decode $_;
2117 /\.map$/
2118 ? normalise $_
2119 : ()
2120 } @{ aio_readdir $TMPDIR or [] }
2121 ]
2122}
2123
2124=item $maps = cf::map::random_maps
2125
2126Returns an arrayref with all map paths of currently instantiated and saved
2127random maps. May block.
2128
2129=cut
2130
2131sub random_maps() {
2132 [
2133 map {
2134 utf8::decode $_;
2135 /\.map$/
2136 ? normalise "?random/$_"
2137 : ()
2138 } @{ aio_readdir $RANDOMDIR or [] }
2139 ]
2140}
2141
1581=item cf::map::unique_maps 2142=item cf::map::unique_maps
1582 2143
1583Returns an arrayref of paths of all shared maps that have 2144Returns an arrayref of paths of all shared maps that have
1584instantiated unique items. May block. 2145instantiated unique items. May block.
1585 2146
1586=cut 2147=cut
1587 2148
1588sub unique_maps() { 2149sub unique_maps() {
1589 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2150 [
1590 or return; 2151 map {
1591
1592 my @paths;
1593
1594 for (@$files) {
1595 utf8::decode $_; 2152 utf8::decode $_;
1596 next if /\.pst$/;
1597 next unless /^$PATH_SEP/o;
1598
1599 s/\.map$//; 2153 /\.map$/
1600 push @paths, $_; 2154 ? normalise $_
2155 : ()
2156 } @{ aio_readdir $UNIQUEDIR or [] }
1601 } 2157 ]
1602
1603 \@paths
1604} 2158}
1605 2159
1606package cf; 2160package cf;
1607 2161
1608=back 2162=back
1654 2208
1655 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2209 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1656 2210
1657 if ($self->{record_replies}) { 2211 if ($self->{record_replies}) {
1658 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2212 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2213
1659 } else { 2214 } else {
2215 my $pl = $self->contr;
2216
2217 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2218 my $diag = $pl->{npc_dialog};
2219 $diag->{pl}->ext_reply (
2220 $diag->{id},
2221 msgtype => "reply",
2222 msg => $diag->{pl}->expand_cfpod ($msg),
2223 add_topics => []
2224 );
2225
2226 } else {
1660 $msg = $npc->name . " says: $msg" if $npc; 2227 $msg = $npc->name . " says: $msg" if $npc;
1661 $self->message ($msg, $flags); 2228 $self->message ($msg, $flags);
2229 }
1662 } 2230 }
1663} 2231}
1664 2232
1665=item $player_object->may ("access") 2233=item $player_object->may ("access")
1666 2234
1699=cut 2267=cut
1700 2268
1701sub link_map { 2269sub link_map {
1702 unless ($LINK_MAP) { 2270 unless ($LINK_MAP) {
1703 $LINK_MAP = cf::map::find "{link}" 2271 $LINK_MAP = cf::map::find "{link}"
1704 or do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 }; 2272 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1705 $LINK_MAP->load; 2273 $LINK_MAP->load;
1706 } 2274 }
1707 2275
1708 $LINK_MAP 2276 $LINK_MAP
1709} 2277}
1714 $self->deactivate_recursive; 2282 $self->deactivate_recursive;
1715 2283
1716 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2284 return if UNIVERSAL::isa $self->map, "ext::map_link";
1717 2285
1718 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2286 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1719 if $self->map; 2287 if $self->map && $self->map->{path} ne "{link}";
1720 2288
1721 $self->enter_map ($LINK_MAP || link_map, 20, 20); 2289 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1722} 2290}
1723 2291
1724sub cf::object::player::leave_link { 2292sub cf::object::player::leave_link {
1725 my ($self, $map, $x, $y) = @_; 2293 my ($self, $map, $x, $y) = @_;
2294
2295 return unless $self->contr->active;
1726 2296
1727 my $link_pos = delete $self->{_link_pos}; 2297 my $link_pos = delete $self->{_link_pos};
1728 2298
1729 unless ($map) { 2299 unless ($map) {
1730 # restore original map position 2300 # restore original map position
1748 $map->load; 2318 $map->load;
1749 $map->load_diag; 2319 $map->load_diag;
1750 2320
1751 return unless $self->contr->active; 2321 return unless $self->contr->active;
1752 $self->activate_recursive; 2322 $self->activate_recursive;
2323
2324 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1753 $self->enter_map ($map, $x, $y); 2325 $self->enter_map ($map, $x, $y);
1754} 2326}
1755 2327
1756cf::player->attach ( 2328=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1757 on_logout => sub {
1758 my ($pl) = @_;
1759 2329
1760 # abort map switching before logout 2330Moves the player to the given map-path and coordinates by first freezing
1761 if ($pl->ob->{_link_pos}) { 2331her, loading and preparing them map, calling the provided $check callback
1762 cf::sync_job { 2332that has to return the map if sucecssful, and then unfreezes the player on
1763 $pl->ob->leave_link 2333the new (success) or old (failed) map position. In either case, $done will
1764 }; 2334be called at the end of this process.
1765 }
1766 },
1767 on_login => sub {
1768 my ($pl) = @_;
1769 2335
1770 # try to abort aborted map switching on player login :)
1771 # should happen only on crashes
1772 if ($pl->ob->{_link_pos}) {
1773 $pl->ob->enter_link;
1774 (async {
1775 # we need this sleep as the login has a concurrent enter_exit running
1776 # and this sleep increases chances of the player not ending up in scorn
1777 $pl->ob->reply (undef,
1778 "There was an internal problem at your last logout, "
1779 . "the server will try to bring you to your intended destination in a second.",
1780 cf::NDI_RED);
1781 Coro::Timer::sleep 1;
1782 $pl->ob->leave_link;
1783 })->prio (2);
1784 }
1785 },
1786);
1787
1788=item $player_object->goto ($path, $x, $y)
1789
1790=cut 2336=cut
2337
2338our $GOTOGEN;
1791 2339
1792sub cf::object::player::goto { 2340sub cf::object::player::goto {
1793 my ($self, $path, $x, $y) = @_; 2341 my ($self, $path, $x, $y, $check, $done) = @_;
2342
2343 # do generation counting so two concurrent goto's will be executed in-order
2344 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1794 2345
1795 $self->enter_link; 2346 $self->enter_link;
1796 2347
1797 (async { 2348 (async {
2349 my $map = eval {
1798 my $map = cf::map::find $path; 2350 my $map = cf::map::find $path;
2351
2352 if ($map) {
1799 $map = $map->customise_for ($self) if $map; 2353 $map = $map->customise_for ($self);
1800 2354 $map = $check->($map) if $check && $map;
1801# warn "entering ", $map->path, " at ($x, $y)\n" 2355 } else {
1802# if $map;
1803
1804 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2356 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2357 }
1805 2358
2359 $map
2360 };
2361
2362 if ($@) {
2363 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2364 LOG llevError | logBacktrace, Carp::longmess $@;
2365 }
2366
2367 if ($gen == $self->{_goto_generation}) {
2368 delete $self->{_goto_generation};
1806 $self->leave_link ($map, $x, $y); 2369 $self->leave_link ($map, $x, $y);
2370 }
2371
2372 $done->() if $done;
1807 })->prio (1); 2373 })->prio (1);
1808} 2374}
1809 2375
1810=item $player_object->enter_exit ($exit_object) 2376=item $player_object->enter_exit ($exit_object)
1811 2377
1840 # that depends on the exit object 2406 # that depends on the exit object
1841 2407
1842 my $rmp = parse_random_map_params $exit->msg; 2408 my $rmp = parse_random_map_params $exit->msg;
1843 2409
1844 if ($exit->map) { 2410 if ($exit->map) {
1845 $rmp->{region} = $exit->map->region_name; 2411 $rmp->{region} = $exit->region->name;
1846 $rmp->{origin_map} = $exit->map->path; 2412 $rmp->{origin_map} = $exit->map->path;
1847 $rmp->{origin_x} = $exit->x; 2413 $rmp->{origin_x} = $exit->x;
1848 $rmp->{origin_y} = $exit->y; 2414 $rmp->{origin_y} = $exit->y;
1849 } 2415 }
1850 2416
1851 $rmp->{random_seed} ||= $exit->random_seed; 2417 $rmp->{random_seed} ||= $exit->random_seed;
1852 2418
1853 my $data = cf::to_json $rmp; 2419 my $data = cf::to_json $rmp;
1854 my $md5 = Digest::MD5::md5_hex $data; 2420 my $md5 = Digest::MD5::md5_hex $data;
1855 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2421 my $meta = "$RANDOMDIR/$md5.meta";
1856 2422
1857 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2423 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1858 aio_write $fh, 0, (length $data), $data, 0; 2424 aio_write $fh, 0, (length $data), $data, 0;
1859 undef $fh; 2425 undef $fh;
1860 aio_rename "$meta~", $meta; 2426 aio_rename "$meta~", $meta;
1867sub cf::object::player::enter_exit { 2433sub cf::object::player::enter_exit {
1868 my ($self, $exit) = @_; 2434 my ($self, $exit) = @_;
1869 2435
1870 return unless $self->type == cf::PLAYER; 2436 return unless $self->type == cf::PLAYER;
1871 2437
2438 if ($exit->slaying eq "/!") {
2439 #TODO: this should de-fi-ni-te-ly not be a sync-job
2440 # the problem is that $exit might not survive long enough
2441 # so it needs to be done right now, right here
2442 cf::sync_job { prepare_random_map $exit };
2443 }
2444
2445 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2446 my $hp = $exit->stats->hp;
2447 my $sp = $exit->stats->sp;
2448
1872 $self->enter_link; 2449 $self->enter_link;
2450
2451 # if exit is damned, update players death & WoR home-position
2452 $self->contr->savebed ($slaying, $hp, $sp)
2453 if $exit->flag (FLAG_DAMNED);
1873 2454
1874 (async { 2455 (async {
1875 $self->deactivate_recursive; # just to be sure 2456 $self->deactivate_recursive; # just to be sure
1876 unless (eval { 2457 unless (eval {
1877 prepare_random_map $exit 2458 $self->goto ($slaying, $hp, $sp);
1878 if $exit->slaying eq "/!";
1879
1880 my $path = new_from_path cf::map $exit->slaying, $exit->map && $exit->map->path;
1881 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1882 2459
1883 1; 2460 1;
1884 }) { 2461 }) {
1885 $self->message ("Something went wrong deep within the crossfire server. " 2462 $self->message ("Something went wrong deep within the crossfire server. "
1886 . "I'll try to bring you back to the map you were before. " 2463 . "I'll try to bring you back to the map you were before. "
1887 . "Please report this to the dungeon master!", 2464 . "Please report this to the dungeon master!",
1888 cf::NDI_UNIQUE | cf::NDI_RED); 2465 cf::NDI_UNIQUE | cf::NDI_RED);
1889 2466
1890 warn "ERROR in enter_exit: $@"; 2467 warn "ERROR in enter_exit: $@";
1891 $self->leave_link; 2468 $self->leave_link;
1892 } 2469 }
1893 })->prio (1); 2470 })->prio (1);
1906 2483
1907sub cf::client::send_drawinfo { 2484sub cf::client::send_drawinfo {
1908 my ($self, $text, $flags) = @_; 2485 my ($self, $text, $flags) = @_;
1909 2486
1910 utf8::encode $text; 2487 utf8::encode $text;
1911 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2488 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1912} 2489}
1913 2490
2491=item $client->send_msg ($channel, $msg, $color, [extra...])
2492
2493Send a drawinfo or msg packet to the client, formatting the msg for the
2494client if neccessary. C<$type> should be a string identifying the type of
2495the message, with C<log> being the default. If C<$color> is negative, suppress
2496the message unless the client supports the msg packet.
2497
2498=cut
2499
2500sub cf::client::send_msg {
2501 my ($self, $channel, $msg, $color, @extra) = @_;
2502
2503 $msg = $self->pl->expand_cfpod ($msg);
2504
2505 $color &= ~cf::NDI_UNIQUE; # just in case...
2506
2507 if (ref $channel) {
2508 # send meta info to client, if not yet sent
2509 unless (exists $self->{channel}{$channel->{id}}) {
2510 $self->{channel}{$channel->{id}} = $channel;
2511 $self->ext_event (channel_info => %$channel);
2512 }
2513
2514 $channel = $channel->{id};
2515 }
2516
2517 return unless @extra || length $msg;
2518
2519 if ($self->can_msg) {
2520 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $channel, $msg, @extra]));
2521 } else {
2522 # replace some tags by gcfclient-compatible ones
2523 for ($msg) {
2524 1 while
2525 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2526 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2527 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2528 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2529 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2530 }
2531
2532 if ($color >= 0) {
2533 if (0 && $msg =~ /\[/) {
2534 $self->send_packet ("drawextinfo $color 4 0 $msg")
2535 } else {
2536 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2537 $self->send_packet ("drawinfo $color $msg")
2538 }
2539 }
2540 }
2541}
2542
2543=item $client->ext_event ($type, %msg)
2544
2545Sends an ext event to the client.
2546
2547=cut
2548
2549sub cf::client::ext_event($$%) {
2550 my ($self, $type, %msg) = @_;
2551
2552 return unless $self->extcmd;
2553
2554 $msg{msgtype} = "event_$type";
2555 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2556}
1914 2557
1915=item $success = $client->query ($flags, "text", \&cb) 2558=item $success = $client->query ($flags, "text", \&cb)
1916 2559
1917Queues a query to the client, calling the given callback with 2560Queues a query to the client, calling the given callback with
1918the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2561the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1919C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2562C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1920 2563
1921Queries can fail, so check the return code. Or don't, as queries will become 2564Queries can fail, so check the return code. Or don't, as queries will
1922reliable at some point in the future. 2565become reliable at some point in the future.
1923 2566
1924=cut 2567=cut
1925 2568
1926sub cf::client::query { 2569sub cf::client::query {
1927 my ($self, $flags, $text, $cb) = @_; 2570 my ($self, $flags, $text, $cb) = @_;
1935 utf8::encode $text; 2578 utf8::encode $text;
1936 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2579 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1937 2580
1938 $self->send_packet ($self->{query_queue}[0][0]) 2581 $self->send_packet ($self->{query_queue}[0][0])
1939 if @{ $self->{query_queue} } == 1; 2582 if @{ $self->{query_queue} } == 1;
2583
2584 1
1940} 2585}
1941 2586
1942cf::client->attach ( 2587cf::client->attach (
2588 on_connect => sub {
2589 my ($ns) = @_;
2590
2591 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2592 },
1943 on_reply => sub { 2593 on_reply => sub {
1944 my ($ns, $msg) = @_; 2594 my ($ns, $msg) = @_;
1945 2595
1946 # this weird shuffling is so that direct followup queries 2596 # this weird shuffling is so that direct followup queries
1947 # get handled first 2597 # get handled first
1948 my $queue = delete $ns->{query_queue} 2598 my $queue = delete $ns->{query_queue}
1949 or return; # be conservative, not sure how that can happen, but we saw a crash here 2599 or return; # be conservative, not sure how that can happen, but we saw a crash here
1950 2600
1951 (shift @$queue)->[1]->($msg); 2601 (shift @$queue)->[1]->($msg);
2602 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1952 2603
1953 push @{ $ns->{query_queue} }, @$queue; 2604 push @{ $ns->{query_queue} }, @$queue;
1954 2605
1955 if (@{ $ns->{query_queue} } == @$queue) { 2606 if (@{ $ns->{query_queue} } == @$queue) {
1956 if (@$queue) { 2607 if (@$queue) {
1958 } else { 2609 } else {
1959 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2610 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1960 } 2611 }
1961 } 2612 }
1962 }, 2613 },
2614 on_exticmd => sub {
2615 my ($ns, $buf) = @_;
2616
2617 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2618
2619 if (ref $msg) {
2620 if (my $cb = $EXTICMD{$msg->{msgtype}}) {
2621 if (my %reply = $cb->($ns, $msg)) {
2622 $reply{msgid} = $msg->{msgid};
2623 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2624 }
2625 }
2626 } else {
2627 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2628 }
2629
2630 cf::override;
2631 },
1963); 2632);
1964 2633
1965=item $client->async (\&cb) 2634=item $client->async (\&cb)
1966 2635
1967Create a new coroutine, running the specified callback. The coroutine will 2636Create a new coroutine, running the specified callback. The coroutine will
2014 2683
2015# here we export the classes and methods available to script code 2684# here we export the classes and methods available to script code
2016 2685
2017=pod 2686=pod
2018 2687
2019The following fucntions and emthods are available within a safe environment: 2688The following functions and methods are available within a safe environment:
2020 2689
2021 cf::object contr pay_amount pay_player map 2690 cf::object
2691 contr pay_amount pay_player map x y force_find force_add
2692 insert remove
2693
2022 cf::object::player player 2694 cf::object::player
2023 cf::player peaceful 2695 player
2024 cf::map trigger 2696
2697 cf::player
2698 peaceful
2699
2700 cf::map
2701 trigger
2025 2702
2026=cut 2703=cut
2027 2704
2028for ( 2705for (
2029 ["cf::object" => qw(contr pay_amount pay_player map)], 2706 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2707 insert remove)],
2030 ["cf::object::player" => qw(player)], 2708 ["cf::object::player" => qw(player)],
2031 ["cf::player" => qw(peaceful)], 2709 ["cf::player" => qw(peaceful)],
2032 ["cf::map" => qw(trigger)], 2710 ["cf::map" => qw(trigger)],
2033) { 2711) {
2034 no strict 'refs'; 2712 no strict 'refs';
2105=back 2783=back
2106 2784
2107=cut 2785=cut
2108 2786
2109############################################################################# 2787#############################################################################
2788# the server's init and main functions
2110 2789
2111=head2 EXTENSION DATABASE SUPPORT 2790sub load_facedata($) {
2791 my ($path) = @_;
2112 2792
2113Crossfire maintains a very simple database for extension use. It can 2793 warn "loading facedata from $path\n";
2114currently store anything that can be serialised using Storable, which
2115excludes objects.
2116 2794
2117The parameter C<$family> should best start with the name of the extension 2795 my $facedata;
2118using it, it should be unique. 2796 0 < aio_load $path, $facedata
2797 or die "$path: $!";
2119 2798
2120=over 4 2799 $facedata = Coro::Storable::thaw $facedata;
2121 2800
2122=item $hashref = cf::db_get $family 2801 $facedata->{version} == 2
2802 or cf::cleanup "$path: version mismatch, cannot proceed.";
2123 2803
2124Return a hashref for use by the extension C<$family>, which can be
2125modified. After modifications, you have to call C<cf::db_dirty> or
2126C<cf::db_sync>.
2127
2128=item $value = cf::db_get $family => $key
2129
2130Returns a single value from the database
2131
2132=item cf::db_put $family => $hashref
2133
2134Stores the given family hashref into the database. Updates are delayed, if
2135you want the data to be synced to disk immediately, use C<cf::db_sync>.
2136
2137=item cf::db_put $family => $key => $value
2138
2139Stores the given C<$value> in the family hash. Updates are delayed, if you
2140want the data to be synced to disk immediately, use C<cf::db_sync>.
2141
2142=item cf::db_dirty
2143
2144Marks the database as dirty, to be updated at a later time.
2145
2146=item cf::db_sync
2147
2148Immediately write the database to disk I<if it is dirty>.
2149
2150=cut
2151
2152our $DB;
2153
2154{
2155 my $path = cf::localdir . "/database.pst";
2156
2157 sub db_load() {
2158 $DB = stat $path ? Storable::retrieve $path : { };
2159 } 2804 {
2805 my $faces = $facedata->{faceinfo};
2160 2806
2161 my $pid; 2807 while (my ($face, $info) = each %$faces) {
2808 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2809 cf::face::set_visibility $idx, $info->{visibility};
2810 cf::face::set_magicmap $idx, $info->{magicmap};
2811 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2812 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2162 2813
2163 sub db_save() { 2814 cf::cede_to_tick;
2164 waitpid $pid, 0 if $pid;
2165 if (0 == ($pid = fork)) {
2166 $DB->{_meta}{version} = 1;
2167 Storable::nstore $DB, "$path~";
2168 rename "$path~", $path;
2169 cf::_exit 0 if defined $pid;
2170 }
2171 }
2172
2173 my $dirty;
2174
2175 sub db_sync() {
2176 db_save if $dirty;
2177 undef $dirty;
2178 }
2179
2180 my $idle = Event->idle (min => 10, max => 20, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
2181 db_sync;
2182 });
2183
2184 sub db_dirty() {
2185 $dirty = 1;
2186 $idle->start;
2187 }
2188
2189 sub db_get($;$) {
2190 @_ >= 2
2191 ? $DB->{$_[0]}{$_[1]}
2192 : ($DB->{$_[0]} ||= { })
2193 }
2194
2195 sub db_put($$;$) {
2196 if (@_ >= 3) {
2197 $DB->{$_[0]}{$_[1]} = $_[2];
2198 } else {
2199 $DB->{$_[0]} = $_[1];
2200 }
2201 db_dirty;
2202 }
2203
2204 cf::global->attach (
2205 prio => 10000,
2206 on_cleanup => sub {
2207 db_sync;
2208 }, 2815 }
2209 );
2210}
2211 2816
2212############################################################################# 2817 while (my ($face, $info) = each %$faces) {
2213# the server's main() 2818 next unless $info->{smooth};
2819 my $idx = cf::face::find $face
2820 or next;
2821 if (my $smooth = cf::face::find $info->{smooth}) {
2822 cf::face::set_smooth $idx, $smooth;
2823 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2824 } else {
2825 warn "smooth face '$info->{smooth}' not found for face '$face'";
2826 }
2827
2828 cf::cede_to_tick;
2829 }
2830 }
2831
2832 {
2833 my $anims = $facedata->{animinfo};
2834
2835 while (my ($anim, $info) = each %$anims) {
2836 cf::anim::set $anim, $info->{frames}, $info->{facings};
2837 cf::cede_to_tick;
2838 }
2839
2840 cf::anim::invalidate_all; # d'oh
2841 }
2842
2843 {
2844 # TODO: for gcfclient pleasure, we should give resources
2845 # that gcfclient doesn't grok a >10000 face index.
2846 my $res = $facedata->{resource};
2847 my $enc = JSON::XS->new->utf8->canonical;
2848
2849 while (my ($name, $info) = each %$res) {
2850 my $meta = $enc->encode ({
2851 name => $name,
2852 type => $info->{type},
2853 copyright => $info->{copyright}, #TODO#
2854 });
2855
2856 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2857
2858 if ($name =~ /\.jpg$/) {
2859 cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack
2860 cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack
2861 } else {
2862 my $data = pack "(w/a*)*", $meta, $info->{data};
2863 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2864
2865 cf::face::set_type $idx, 1;
2866 cf::face::set_data $idx, 0, $data, $chk;
2867 }
2868
2869 cf::cede_to_tick;
2870 }
2871 }
2872
2873 1
2874}
2875
2876sub reload_regions {
2877 load_resource_file "$MAPDIR/regions"
2878 or die "unable to load regions file\n";
2879
2880 for (cf::region::list) {
2881 $_->{match} = qr/$_->{match}/
2882 if exists $_->{match};
2883 }
2884}
2885
2886sub reload_facedata {
2887 load_facedata "$DATADIR/facedata"
2888 or die "unable to load facedata\n";
2889}
2890
2891sub reload_archetypes {
2892 load_resource_file "$DATADIR/archetypes"
2893 or die "unable to load archetypes\n";
2894 #d# NEED to laod twice to resolve forward references
2895 # this really needs to be done in an extra post-pass
2896 # (which needs to be synchronous, so solve it differently)
2897 load_resource_file "$DATADIR/archetypes"
2898 or die "unable to load archetypes\n";
2899}
2900
2901sub reload_treasures {
2902 load_resource_file "$DATADIR/treasures"
2903 or die "unable to load treasurelists\n";
2904}
2905
2906sub reload_resources {
2907 warn "reloading resource files...\n";
2908
2909 reload_regions;
2910 reload_facedata;
2911 #reload_archetypes;#d#
2912 reload_archetypes;
2913 reload_treasures;
2914
2915 warn "finished reloading resource files\n";
2916}
2917
2918sub init {
2919 reload_resources;
2920}
2214 2921
2215sub cfg_load { 2922sub cfg_load {
2216 open my $fh, "<:utf8", cf::confdir . "/config" 2923 open my $fh, "<:utf8", "$CONFDIR/config"
2217 or return; 2924 or return;
2218 2925
2219 local $/; 2926 local $/;
2220 *CFG = YAML::Syck::Load <$fh>; 2927 *CFG = YAML::Syck::Load <$fh>;
2221 2928
2241 Event::one_event; 2948 Event::one_event;
2242 })->prio (Coro::PRIO_MAX); 2949 })->prio (Coro::PRIO_MAX);
2243 }; 2950 };
2244 2951
2245 cfg_load; 2952 cfg_load;
2246 db_load; 2953 db_init;
2247 load_extensions; 2954 load_extensions;
2248 2955
2249 $TICK_WATCHER->start; 2956 $TICK_WATCHER->start;
2250 Event::loop; 2957 Event::loop;
2251} 2958}
2255 2962
2256# install some emergency cleanup handlers 2963# install some emergency cleanup handlers
2257BEGIN { 2964BEGIN {
2258 for my $signal (qw(INT HUP TERM)) { 2965 for my $signal (qw(INT HUP TERM)) {
2259 Event->signal ( 2966 Event->signal (
2967 reentrant => 0,
2260 data => WF_AUTOCANCEL, 2968 data => WF_AUTOCANCEL,
2261 signal => $signal, 2969 signal => $signal,
2970 prio => 0,
2262 cb => sub { 2971 cb => sub {
2263 cf::cleanup "SIG$signal"; 2972 cf::cleanup "SIG$signal";
2264 }, 2973 },
2265 ); 2974 );
2266 } 2975 }
2976}
2977
2978sub write_runtime {
2979 my $runtime = "$LOCALDIR/runtime";
2980
2981 # first touch the runtime file to show we are still running:
2982 # the fsync below can take a very very long time.
2983
2984 IO::AIO::aio_utime $runtime, undef, undef;
2985
2986 my $guard = cf::lock_acquire "write_runtime";
2987
2988 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2989 or return;
2990
2991 my $value = $cf::RUNTIME + 90 + 10;
2992 # 10 is the runtime save interval, for a monotonic clock
2993 # 60 allows for the watchdog to kill the server.
2994
2995 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2996 and return;
2997
2998 # always fsync - this file is important
2999 aio_fsync $fh
3000 and return;
3001
3002 # touch it again to show we are up-to-date
3003 aio_utime $fh, undef, undef;
3004
3005 close $fh
3006 or return;
3007
3008 aio_rename "$runtime~", $runtime
3009 and return;
3010
3011 warn "runtime file written.\n";
3012
3013 1
2267} 3014}
2268 3015
2269sub emergency_save() { 3016sub emergency_save() {
2270 my $freeze_guard = cf::freeze_mainloop; 3017 my $freeze_guard = cf::freeze_mainloop;
2271 3018
2288 my $map = $cf::MAP{$path} or next; 3035 my $map = $cf::MAP{$path} or next;
2289 $map->valid or next; 3036 $map->valid or next;
2290 $map->save; 3037 $map->save;
2291 } 3038 }
2292 warn "end emergency map save\n"; 3039 warn "end emergency map save\n";
3040
3041 warn "begin emergency database checkpoint\n";
3042 BDB::db_env_txn_checkpoint $DB_ENV;
3043 warn "end emergency database checkpoint\n";
2293 }; 3044 };
2294 3045
2295 warn "leave emergency perl save\n"; 3046 warn "leave emergency perl save\n";
2296} 3047}
2297 3048
3049sub post_cleanup {
3050 my ($make_core) = @_;
3051
3052 warn Carp::longmess "post_cleanup backtrace"
3053 if $make_core;
3054}
3055
2298sub reload() { 3056sub do_reload_perl() {
2299 # can/must only be called in main 3057 # can/must only be called in main
2300 if ($Coro::current != $Coro::main) { 3058 if ($Coro::current != $Coro::main) {
2301 warn "can only reload from main coroutine"; 3059 warn "can only reload from main coroutine";
2302 return; 3060 return;
2303 } 3061 }
2304 3062
2305 warn "reloading..."; 3063 warn "reloading...";
2306 3064
2307 warn "cancelling server ticker"; 3065 warn "entering sync_job";
2308 $TICK_WATCHER->cancel;
2309 3066
3067 cf::sync_job {
3068 cf::write_runtime; # external watchdog should not bark
2310 cf::emergency_save; 3069 cf::emergency_save;
3070 cf::write_runtime; # external watchdog should not bark
2311 3071
2312 eval { 3072 warn "syncing database to disk";
3073 BDB::db_env_txn_checkpoint $DB_ENV;
3074
2313 # if anything goes wrong in here, we should simply crash as we already saved 3075 # if anything goes wrong in here, we should simply crash as we already saved
2314
2315 warn "syncing database to disk";
2316 cf::db_sync;
2317 3076
2318 warn "cancelling all WF_AUTOCANCEL watchers"; 3077 warn "cancelling all WF_AUTOCANCEL watchers";
2319 for (Event::all_watchers) { 3078 for (Event::all_watchers) {
2320 $_->cancel if $_->data & WF_AUTOCANCEL; 3079 $_->cancel if $_->data & WF_AUTOCANCEL;
2321 } 3080 }
2322 3081
2323 warn "flushing outstanding aio requests"; 3082 warn "flushing outstanding aio requests";
2324 for (;;) { 3083 for (;;) {
3084 BDB::flush;
2325 IO::AIO::flush; 3085 IO::AIO::flush;
2326 Coro::cede; 3086 Coro::cede;
2327 last unless IO::AIO::nreqs; 3087 last unless IO::AIO::nreqs || BDB::nreqs;
2328 warn "iterate..."; 3088 warn "iterate...";
2329 } 3089 }
3090
3091 ++$RELOAD;
2330 3092
2331 warn "cancelling all extension coros"; 3093 warn "cancelling all extension coros";
2332 $_->cancel for values %EXT_CORO; 3094 $_->cancel for values %EXT_CORO;
2333 %EXT_CORO = (); 3095 %EXT_CORO = ();
2334 3096
2335 warn "removing commands"; 3097 warn "removing commands";
2336 %COMMAND = (); 3098 %COMMAND = ();
2337 3099
2338 warn "removing ext commands"; 3100 warn "removing ext/exti commands";
2339 %EXTCMD = (); 3101 %EXTCMD = ();
3102 %EXTICMD = ();
2340 3103
2341 warn "unloading/nuking all extensions"; 3104 warn "unloading/nuking all extensions";
2342 for my $pkg (@EXTS) { 3105 for my $pkg (@EXTS) {
2343 warn "... unloading $pkg"; 3106 warn "... unloading $pkg";
2344 3107
2374 Symbol::delete_package "safe::$_" 3137 Symbol::delete_package "safe::$_"
2375 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3138 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2376 3139
2377 warn "unloading cf.pm \"a bit\""; 3140 warn "unloading cf.pm \"a bit\"";
2378 delete $INC{"cf.pm"}; 3141 delete $INC{"cf.pm"};
3142 delete $INC{"cf/pod.pm"};
2379 3143
2380 # don't, removes xs symbols, too, 3144 # don't, removes xs symbols, too,
2381 # and global variables created in xs 3145 # and global variables created in xs
2382 #Symbol::delete_package __PACKAGE__; 3146 #Symbol::delete_package __PACKAGE__;
2383 3147
2387 require cf; 3151 require cf;
2388 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3152 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2389 3153
2390 warn "loading config and database again"; 3154 warn "loading config and database again";
2391 cf::cfg_load; 3155 cf::cfg_load;
2392 cf::db_load;
2393 3156
2394 warn "loading extensions"; 3157 warn "loading extensions";
2395 cf::load_extensions; 3158 cf::load_extensions;
2396 3159
2397 warn "reattaching attachments to objects/players"; 3160 warn "reattaching attachments to objects/players";
2398 _global_reattach; 3161 _global_reattach; # objects, sockets
2399 warn "reattaching attachments to maps"; 3162 warn "reattaching attachments to maps";
2400 reattach $_ for values %MAP; 3163 reattach $_ for values %MAP;
3164 warn "reattaching attachments to players";
3165 reattach $_ for values %PLAYER;
2401 3166
2402 warn "restarting server ticker"; 3167 warn "leaving sync_job";
2403 3168
2404 $TICK_WATCHER->start; 3169 1
2405 }; 3170 } or do {
2406
2407 if ($@) {
2408 warn $@; 3171 warn $@;
2409 warn "error while reloading, exiting."; 3172 warn "error while reloading, exiting.";
2410 exit 1; 3173 exit 1;
2411 } 3174 };
2412 3175
2413 warn "reloaded"; 3176 warn "reloaded";
2414}; 3177};
2415 3178
2416our $RELOAD_WATCHER; # used only during reload 3179our $RELOAD_WATCHER; # used only during reload
2417 3180
3181sub reload_perl() {
3182 # doing reload synchronously and two reloads happen back-to-back,
3183 # coro crashes during coro_state_free->destroy here.
3184
3185 $RELOAD_WATCHER ||= Event->timer (
3186 reentrant => 0,
3187 after => 0,
3188 data => WF_AUTOCANCEL,
3189 cb => sub {
3190 do_reload_perl;
3191 undef $RELOAD_WATCHER;
3192 },
3193 );
3194}
3195
2418register_command "reload" => sub { 3196register_command "reload" => sub {
2419 my ($who, $arg) = @_; 3197 my ($who, $arg) = @_;
2420 3198
2421 if ($who->flag (FLAG_WIZ)) { 3199 if ($who->flag (FLAG_WIZ)) {
2422 $who->message ("reloading server."); 3200 $who->message ("reloading server.");
2423 3201 async { reload_perl };
2424 # doing reload synchronously and two reloads happen back-to-back,
2425 # coro crashes during coro_state_free->destroy here.
2426
2427 $RELOAD_WATCHER ||= Event->timer (after => 0, data => WF_AUTOCANCEL, cb => sub {
2428 reload;
2429 undef $RELOAD_WATCHER;
2430 });
2431 } 3202 }
2432}; 3203};
2433 3204
2434unshift @INC, $LIBDIR; 3205unshift @INC, $LIBDIR;
2435 3206
2436my $bug_warning = 0; 3207my $bug_warning = 0;
2437 3208
3209our @WAIT_FOR_TICK;
3210our @WAIT_FOR_TICK_BEGIN;
3211
3212sub wait_for_tick {
3213 return unless $TICK_WATCHER->is_active;
3214 return if $Coro::current == $Coro::main;
3215
3216 my $signal = new Coro::Signal;
3217 push @WAIT_FOR_TICK, $signal;
3218 $signal->wait;
3219}
3220
3221sub wait_for_tick_begin {
3222 return unless $TICK_WATCHER->is_active;
3223 return if $Coro::current == $Coro::main;
3224
3225 my $signal = new Coro::Signal;
3226 push @WAIT_FOR_TICK_BEGIN, $signal;
3227 $signal->wait;
3228}
3229
3230 my $min = 1e6;#d#
3231 my $avg = 10;
2438$TICK_WATCHER = Event->timer ( 3232$TICK_WATCHER = Event->timer (
2439 reentrant => 0, 3233 reentrant => 0,
2440 parked => 1, 3234 parked => 1,
2441 prio => 0, 3235 prio => 0,
2442 at => $NEXT_TICK || $TICK, 3236 at => $NEXT_TICK || $TICK,
2446 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3240 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2447 unless ++$bug_warning > 10; 3241 unless ++$bug_warning > 10;
2448 return; 3242 return;
2449 } 3243 }
2450 3244
2451 $NOW = Event::time; 3245 $NOW = $tick_start = Event::time;
2452 3246
2453 cf::server_tick; # one server iteration 3247 cf::server_tick; # one server iteration
3248
3249 0 && sync_job {#d#
3250 for(1..10) {
3251 my $t = Event::time;
3252 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3253 or die;
3254
3255 $map->width (50);
3256 $map->height (50);
3257 $map->alloc;
3258 $map->_load_objects ("/tmp/x.map", 1);
3259 my $t = Event::time - $t;
3260
3261 #next unless $t < 0.0013;#d#
3262 if ($t < $min) {
3263 $min = $t;
3264 }
3265 $avg = $avg * 0.99 + $t * 0.01;
3266 }
3267 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3268 exit 0;
3269 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3270 };
3271
2454 $RUNTIME += $TICK; 3272 $RUNTIME += $TICK;
2455 $NEXT_TICK += $TICK; 3273 $NEXT_TICK += $TICK;
2456 3274
2457 $WAIT_FOR_TICK->broadcast; 3275 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2458 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited; 3276 $NEXT_RUNTIME_WRITE = $NOW + 10;
3277 Coro::async_pool {
3278 write_runtime
3279 or warn "ERROR: unable to write runtime file: $!";
3280 };
3281 }
3282
3283# my $AFTER = Event::time;
3284# warn $AFTER - $NOW;#d#
3285
3286 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3287 $sig->send;
3288 }
3289 while (my $sig = shift @WAIT_FOR_TICK) {
3290 $sig->send;
3291 }
3292
3293 $NOW = Event::time;
2459 3294
2460 # if we are delayed by four ticks or more, skip them all 3295 # if we are delayed by four ticks or more, skip them all
2461 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3296 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2462 3297
2463 $TICK_WATCHER->at ($NEXT_TICK); 3298 $TICK_WATCHER->at ($NEXT_TICK);
2464 $TICK_WATCHER->start; 3299 $TICK_WATCHER->start;
3300
3301 $LOAD = ($NOW - $tick_start) / $TICK;
3302 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3303
3304 _post_tick;
3305
3306
2465 }, 3307 },
2466); 3308);
2467 3309
3310{
3311 BDB::max_poll_time $TICK * 0.1;
3312 $BDB_POLL_WATCHER = Event->io (
3313 reentrant => 0,
3314 fd => BDB::poll_fileno,
3315 poll => 'r',
3316 prio => 0,
3317 data => WF_AUTOCANCEL,
3318 cb => \&BDB::poll_cb,
3319 );
3320 BDB::min_parallel 8;
3321
3322 BDB::set_sync_prepare {
3323 my $status;
3324 my $current = $Coro::current;
3325 (
3326 sub {
3327 $status = $!;
3328 $current->ready; undef $current;
3329 },
3330 sub {
3331 Coro::schedule while defined $current;
3332 $! = $status;
3333 },
3334 )
3335 };
3336
3337 unless ($DB_ENV) {
3338 $DB_ENV = BDB::db_env_create;
3339
3340 cf::sync_job {
3341 eval {
3342 BDB::db_env_open
3343 $DB_ENV,
3344 $BDBDIR,
3345 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3346 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3347 0666;
3348
3349 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3350
3351 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3352 $DB_ENV->set_lk_detect;
3353 };
3354
3355 cf::cleanup "db_env_open(db): $@" if $@;
3356 };
3357 }
3358}
3359
3360{
3361 IO::AIO::min_parallel 8;
3362
3363 undef $Coro::AIO::WATCHER;
2468IO::AIO::max_poll_time $TICK * 0.2; 3364 IO::AIO::max_poll_time $TICK * 0.1;
2469
2470$AIO_POLL_WATCHER = Event->io ( 3365 $AIO_POLL_WATCHER = Event->io (
2471 fd => IO::AIO::poll_fileno, 3366 reentrant => 0,
2472 poll => 'r',
2473 prio => 5,
2474 data => WF_AUTOCANCEL,
2475 cb => \&IO::AIO::poll_cb,
2476);
2477
2478$WRITE_RUNTIME_WATCHER = Event->timer (
2479 data => WF_AUTOCANCEL, 3367 data => WF_AUTOCANCEL,
2480 after => 1, 3368 fd => IO::AIO::poll_fileno,
2481 interval => 10, 3369 poll => 'r',
2482 cb => Coro::unblock_sub { 3370 prio => 6,
2483 write_runtime 3371 cb => \&IO::AIO::poll_cb,
2484 or warn "ERROR: unable to write runtime file: $!"; 3372 );
3373}
3374
3375my $_log_backtrace;
3376
3377sub _log_backtrace {
3378 my ($msg, @addr) = @_;
3379
3380 $msg =~ s/\n//;
3381
3382 # limit the # of concurrent backtraces
3383 if ($_log_backtrace < 2) {
3384 ++$_log_backtrace;
3385 async {
3386 my @bt = fork_call {
3387 @addr = map { sprintf "%x", $_ } @addr;
3388 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3389 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3390 or die "addr2line: $!";
3391
3392 my @funcs;
3393 my @res = <$fh>;
3394 chomp for @res;
3395 while (@res) {
3396 my ($func, $line) = splice @res, 0, 2, ();
3397 push @funcs, "[$func] $line";
3398 }
3399
3400 @funcs
3401 };
3402
3403 LOG llevInfo, "[ABT] $msg\n";
3404 LOG llevInfo, "[ABT] $_\n" for @bt;
3405 --$_log_backtrace;
3406 };
3407 } else {
3408 LOG llevInfo, "[ABT] $msg\n";
3409 LOG llevInfo, "[ABT] [suppressed]\n";
2485 }, 3410 }
2486); 3411}
3412
3413# load additional modules
3414use cf::pod;
2487 3415
2488END { cf::emergency_save } 3416END { cf::emergency_save }
2489 3417
24901 34181
2491 3419

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines