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

Comparing cf.schmorp.de/server/lib/cf.pm (file contents):
Revision 1.168 by root, Sun Jan 14 00:37:14 2007 UTC vs.
Revision 1.291 by root, Tue Jul 3 00:54:44 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.3 (); 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;
26 34
35# configure various modules to our taste
36#
37$Storable::canonical = 1; # reduce rsync transfers
38Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
39Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
40
27use Event; $Event::Eval = 1; # no idea why this is required, but it is 41$Event::Eval = 1; # no idea why this is required, but it is
28
29sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
30 42
31# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 43# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
32$YAML::Syck::ImplicitUnicode = 1; 44$YAML::Syck::ImplicitUnicode = 1;
33 45
34$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 46$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
35 47
48sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
49
36our %COMMAND = (); 50our %COMMAND = ();
37our %COMMAND_TIME = (); 51our %COMMAND_TIME = ();
38 52
39our @EXTS = (); # list of extension package names 53our @EXTS = (); # list of extension package names
40our %EXTCMD = (); 54our %EXTCMD = ();
55our %EXTICMD = ();
41our %EXT_CORO = (); # coroutines bound to extensions 56our %EXT_CORO = (); # coroutines bound to extensions
42our %EXT_MAP = (); # pluggable maps 57our %EXT_MAP = (); # pluggable maps
43 58
59our $RELOAD; # number of reloads so far
44our @EVENT; 60our @EVENT;
45our $LIBDIR = datadir . "/ext";
46 61
47our $TICK = MAX_TIME * 1e-6; 62our $CONFDIR = confdir;
63our $DATADIR = datadir;
64our $LIBDIR = "$DATADIR/ext";
65our $PODDIR = "$DATADIR/pod";
66our $MAPDIR = "$DATADIR/" . mapdir;
67our $LOCALDIR = localdir;
68our $TMPDIR = "$LOCALDIR/" . tmpdir;
69our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
70our $PLAYERDIR = "$LOCALDIR/" . playerdir;
71our $RANDOMDIR = "$LOCALDIR/random";
72our $BDBDIR = "$LOCALDIR/db";
73
74our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
48our $TICK_WATCHER; 75our $TICK_WATCHER;
49our $AIO_POLL_WATCHER; 76our $AIO_POLL_WATCHER;
50our $WRITE_RUNTIME_WATCHER; 77our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
51our $NEXT_TICK; 78our $NEXT_TICK;
52our $NOW; 79our $NOW;
80our $USE_FSYNC = 1; # use fsync to write maps - default off
81
82our $BDB_POLL_WATCHER;
83our $DB_ENV;
53 84
54our %CFG; 85our %CFG;
55 86
56our $UPTIME; $UPTIME ||= time; 87our $UPTIME; $UPTIME ||= time;
57our $RUNTIME; 88our $RUNTIME;
58 89
59our %PLAYER; # all users 90our %PLAYER; # all users
60our %MAP; # all maps 91our %MAP; # all maps
61our $LINK_MAP; # the special {link} map, which is always available 92our $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 93
67# used to convert map paths into valid unix filenames by replacing / by ∕ 94# used to convert map paths into valid unix filenames by replacing / by ∕
68our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 95our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
69 96
97our $LOAD; # a number between 0 (idle) and 1 (too many objects)
98our $LOADAVG; # same thing, but with alpha-smoothing
99our $tick_start; # for load detecting purposes
100
70binmode STDOUT; 101binmode STDOUT;
71binmode STDERR; 102binmode STDERR;
72 103
73# read virtual server time, if available 104# read virtual server time, if available
74unless ($RUNTIME || !-e cf::localdir . "/runtime") { 105unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
75 open my $fh, "<", cf::localdir . "/runtime" 106 open my $fh, "<", "$LOCALDIR/runtime"
76 or die "unable to read runtime file: $!"; 107 or die "unable to read runtime file: $!";
77 $RUNTIME = <$fh> + 0.; 108 $RUNTIME = <$fh> + 0.;
78} 109}
79 110
80mkdir cf::localdir; 111mkdir $_
81mkdir cf::localdir . "/" . cf::playerdir; 112 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
82mkdir cf::localdir . "/" . cf::tmpdir;
83mkdir cf::localdir . "/" . cf::uniquedir;
84mkdir $RANDOM_MAPS;
85 113
86our $EMERGENCY_POSITION; 114our $EMERGENCY_POSITION;
115
116sub cf::map::normalise;
87 117
88############################################################################# 118#############################################################################
89 119
90=head2 GLOBAL VARIABLES 120=head2 GLOBAL VARIABLES
91 121
… …
98=item $cf::RUNTIME 128=item $cf::RUNTIME
99 129
100The time this server has run, starts at 0 and is increased by $cf::TICK on 130The time this server has run, starts at 0 and is increased by $cf::TICK on
101every server tick. 131every server tick.
102 132
103=item $cf::LIBDIR 133=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
134$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
135$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
104 136
105The perl library directory, where extensions and cf-specific modules can 137Various directories - "/etc", read-only install directory, perl-library
106be found. It will be added to C<@INC> automatically. 138directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
139unique-items directory, player file directory, random maps directory and
140database environment.
107 141
108=item $cf::NOW 142=item $cf::NOW
109 143
110The time of the last (current) server tick. 144The time of the last (current) server tick.
111 145
112=item $cf::TICK 146=item $cf::TICK
113 147
114The interval between server ticks, in seconds. 148The interval between server ticks, in seconds.
149
150=item $cf::LOADAVG
151
152The current CPU load on the server (alpha-smoothed), as a value between 0
153(none) and 1 (overloaded), indicating how much time is spent on processing
154objects per tick. Healthy values are < 0.5.
155
156=item $cf::LOAD
157
158The raw value load value from the last tick.
115 159
116=item %cf::CFG 160=item %cf::CFG
117 161
118Configuration for the server, loaded from C</etc/crossfire/config>, or 162Configuration for the server, loaded from C</etc/crossfire/config>, or
119from wherever your confdir points to. 163from wherever your confdir points to.
120 164
121=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 165=item cf::wait_for_tick, cf::wait_for_tick_begin
122 166
123These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK) 167These 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 168returns 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 169per 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.
127 170
128=back 171=back
129 172
130=cut 173=cut
131 174
132BEGIN { 175BEGIN {
133 *CORE::GLOBAL::warn = sub { 176 *CORE::GLOBAL::warn = sub {
134 my $msg = join "", @_; 177 my $msg = join "", @_;
135 utf8::encode $msg;
136 178
137 $msg .= "\n" 179 $msg .= "\n"
138 unless $msg =~ /\n$/; 180 unless $msg =~ /\n$/;
139 181
182 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
183
184 utf8::encode $msg;
140 LOG llevError, $msg; 185 LOG llevError, $msg;
141 }; 186 };
142} 187}
143 188
144@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 189@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
145@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 190@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
146@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 191@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
147@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 192@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
148@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 193@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
194@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
149@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 195@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
150 196
151# we bless all objects into (empty) derived classes to force a method lookup 197# we bless all objects into (empty) derived classes to force a method lookup
152# within the Safe compartment. 198# within the Safe compartment.
153for my $pkg (qw( 199for my $pkg (qw(
154 cf::global cf::attachable 200 cf::global cf::attachable
… …
162} 208}
163 209
164$Event::DIED = sub { 210$Event::DIED = sub {
165 warn "error in event callback: @_"; 211 warn "error in event callback: @_";
166}; 212};
213
214#############################################################################
167 215
168=head2 UTILITY FUNCTIONS 216=head2 UTILITY FUNCTIONS
169 217
170=over 4 218=over 4
171 219
… …
190 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 238 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
191 $d 239 $d
192 } || "[unable to dump $_[0]: '$@']"; 240 } || "[unable to dump $_[0]: '$@']";
193} 241}
194 242
195use JSON::Syck (); # TODO# replace by JSON::PC once working
196
197=item $ref = cf::from_json $json 243=item $ref = cf::from_json $json
198 244
199Converts a JSON string into the corresponding perl data structure. 245Converts a JSON string into the corresponding perl data structure.
200 246
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 247=item $json = cf::to_json $ref
209 248
210Converts a perl data structure into its JSON representation. 249Converts a perl data structure into its JSON representation.
211 250
212=cut 251=cut
213 252
214sub to_json($) { 253our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
215 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 254
216 JSON::Syck::Dump $_[0] 255sub to_json ($) { $json_coder->encode ($_[0]) }
217} 256sub from_json ($) { $json_coder->decode ($_[0]) }
218 257
219=item cf::lock_wait $string 258=item cf::lock_wait $string
220 259
221Wait until the given lock is available. See cf::lock_acquire. 260Wait until the given lock is available. See cf::lock_acquire.
222 261
… …
228returned. 267returned.
229 268
230Lock names should begin with a unique identifier (for example, cf::map::find 269Lock names should begin with a unique identifier (for example, cf::map::find
231uses map_find and cf::map::load uses map_load). 270uses map_find and cf::map::load uses map_load).
232 271
272=item $locked = cf::lock_active $string
273
274Return true if the lock is currently active, i.e. somebody has locked it.
275
233=cut 276=cut
234 277
235our %LOCK; 278our %LOCK;
236 279
237sub lock_wait($) { 280sub lock_wait($) {
… …
256 # wake up all waiters, to be on the safe side 299 # wake up all waiters, to be on the safe side
257 $_->ready for @{ delete $LOCK{$key} }; 300 $_->ready for @{ delete $LOCK{$key} };
258 } 301 }
259} 302}
260 303
304sub lock_active($) {
305 my ($key) = @_;
306
307 ! ! $LOCK{$key}
308}
309
261sub freeze_mainloop { 310sub freeze_mainloop {
262 return unless $TICK_WATCHER->is_active; 311 return unless $TICK_WATCHER->is_active;
263 312
264 my $guard = Coro::guard { 313 my $guard = Coro::guard {
265 $TICK_WATCHER->start; 314 $TICK_WATCHER->start;
266 $WRITE_RUNTIME_WATCHER->start;
267 }; 315 };
268 $WRITE_RUNTIME_WATCHER->stop;
269 $TICK_WATCHER->stop; 316 $TICK_WATCHER->stop;
270 $guard 317 $guard
271} 318}
272 319
273=item cf::async { BLOCK } 320=item cf::async { BLOCK }
… …
280 327
281BEGIN { *async = \&Coro::async_pool } 328BEGIN { *async = \&Coro::async_pool }
282 329
283=item cf::sync_job { BLOCK } 330=item cf::sync_job { BLOCK }
284 331
285The design of crossfire+ requires that the main coro ($Coro::main) is 332The design of Crossfire TRT requires that the main coroutine ($Coro::main)
286always able to handle events or runnable, as crossfire+ is only partly 333is 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. 334partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
335acceptable.
288 336
289If it must be done, put the blocking parts into C<sync_job>. This will run 337If 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 338the given BLOCK in another coroutine while waiting for the result. The
291server will be frozen during this time, so the block should either finish 339server will be frozen during this time, so the block should either finish
292fast or be very important. 340fast or be very important.
… …
295 343
296sub sync_job(&) { 344sub sync_job(&) {
297 my ($job) = @_; 345 my ($job) = @_;
298 346
299 if ($Coro::current == $Coro::main) { 347 if ($Coro::current == $Coro::main) {
348 my $time = Event::time;
349
300 # this is the main coro, too bad, we have to block 350 # this is the main coro, too bad, we have to block
301 # till the operation succeeds, freezing the server :/ 351 # till the operation succeeds, freezing the server :/
302 352
303 # TODO: use suspend/resume instead 353 # TODO: use suspend/resume instead
304 # (but this is cancel-safe) 354 # (but this is cancel-safe)
… …
315 365
316 while ($busy) { 366 while ($busy) {
317 Coro::cede or Event::one_event; 367 Coro::cede or Event::one_event;
318 } 368 }
319 369
370 $time = Event::time - $time;
371
372 LOG llevError | logBacktrace, Carp::longmess "long sync job"
373 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
374
375 $tick_start += $time; # do not account sync jobs to server load
376
320 wantarray ? @res : $res[0] 377 wantarray ? @res : $res[0]
321 } else { 378 } else {
322 # we are in another coroutine, how wonderful, everything just works 379 # we are in another coroutine, how wonderful, everything just works
323 380
324 $job->() 381 $job->()
… …
343 $EXT_CORO{$coro+0} = $coro; 400 $EXT_CORO{$coro+0} = $coro;
344 401
345 $coro 402 $coro
346} 403}
347 404
348sub write_runtime { 405=item fork_call { }, $args
349 my $runtime = cf::localdir . "/runtime";
350 406
351 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 407Executes the given code block with the given arguments in a seperate
352 or return; 408process, returning the results. Everything must be serialisable with
409Coro::Storable. May, of course, block. Note that the executed sub may
410never block itself or use any form of Event handling.
353 411
354 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock 412=cut
355 (aio_write $fh, 0, (length $value), $value, 0) <= 0
356 and return;
357 413
358 aio_fsync $fh 414sub fork_call(&@) {
359 and return; 415 my ($cb, @args) = @_;
360 416
417# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
418# or die "socketpair: $!";
419 pipe my $fh1, my $fh2
420 or die "pipe: $!";
421
422 if (my $pid = fork) {
361 close $fh 423 close $fh2;
362 or return;
363 424
364 aio_rename "$runtime~", $runtime 425 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
365 and return; 426 $res = Coro::Storable::thaw $res;
366 427
428 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
429
430 die $$res unless "ARRAY" eq ref $res;
431
432 return wantarray ? @$res : $res->[-1];
433 } else {
434 reset_signals;
435 local $SIG{__WARN__};
436 local $SIG{__DIE__};
437 eval {
438 close $fh1;
439
440 my @res = eval { $cb->(@args) };
441 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
442 };
443
444 warn $@ if $@;
445 _exit 0;
367 1 446 }
447}
448
449=item $value = cf::db_get $family => $key
450
451Returns a single value from the environment database.
452
453=item cf::db_put $family => $key => $value
454
455Stores the given C<$value> in the family. It can currently store binary
456data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
457
458=cut
459
460our $DB;
461
462sub db_init {
463 unless ($DB) {
464 $DB = BDB::db_create $DB_ENV;
465
466 cf::sync_job {
467 eval {
468 $DB->set_flags (BDB::CHKSUM);
469
470 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
471 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
472 cf::cleanup "db_open(db): $!" if $!;
473 };
474 cf::cleanup "db_open(db): $@" if $@;
475 };
476 }
477}
478
479sub db_get($$) {
480 my $key = "$_[0]/$_[1]";
481
482 cf::sync_job {
483 BDB::db_get $DB, undef, $key, my $data;
484
485 $! ? ()
486 : $data
487 }
488}
489
490sub db_put($$$) {
491 BDB::dbreq_pri 4;
492 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
493}
494
495=item cf::cache $id => [$paths...], $processversion => $process
496
497Generic caching function that returns the value of the resource $id,
498caching and regenerating as required.
499
500This function can block.
501
502=cut
503
504sub cache {
505 my ($id, $src, $processversion, $process) = @_;
506
507 my $meta =
508 join "\x00",
509 $processversion,
510 map {
511 aio_stat $_
512 and Carp::croak "$_: $!";
513
514 ($_, (stat _)[7,9])
515 } @$src;
516
517 my $dbmeta = db_get cache => "$id/meta";
518 if ($dbmeta ne $meta) {
519 # changed, we may need to process
520
521 my @data;
522 my $md5;
523
524 for (0 .. $#$src) {
525 0 <= aio_load $src->[$_], $data[$_]
526 or Carp::croak "$src->[$_]: $!";
527 }
528
529 # if processing is expensive, check
530 # checksum first
531 if (1) {
532 $md5 =
533 join "\x00",
534 $processversion,
535 map {
536 Coro::cede;
537 ($src->[$_], Digest::MD5::md5_hex $data[$_])
538 } 0.. $#$src;
539
540
541 my $dbmd5 = db_get cache => "$id/md5";
542 if ($dbmd5 eq $md5) {
543 db_put cache => "$id/meta", $meta;
544
545 return db_get cache => "$id/data";
546 }
547 }
548
549 my $t1 = Time::HiRes::time;
550 my $data = $process->(\@data);
551 my $t2 = Time::HiRes::time;
552
553 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
554
555 db_put cache => "$id/data", $data;
556 db_put cache => "$id/md5" , $md5;
557 db_put cache => "$id/meta", $meta;
558
559 return $data;
560 }
561
562 db_get cache => "$id/data"
563}
564
565=item cf::datalog type => key => value, ...
566
567Log a datalog packet of the given type with the given key-value pairs.
568
569=cut
570
571sub datalog($@) {
572 my ($type, %kv) = @_;
573 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
368} 574}
369 575
370=back 576=back
371 577
372=cut 578=cut
… …
379attach callbacks/event handlers (a collection of which is called an "attachment") 585attach callbacks/event handlers (a collection of which is called an "attachment")
380to it. All such attachable objects support the following methods. 586to it. All such attachable objects support the following methods.
381 587
382In the following description, CLASS can be any of C<global>, C<object> 588In 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 589C<player>, C<client> or C<map> (i.e. the attachable objects in
384crossfire+). 590Crossfire TRT).
385 591
386=over 4 592=over 4
387 593
388=item $attachable->attach ($attachment, key => $value...) 594=item $attachable->attach ($attachment, key => $value...)
389 595
… …
503our @CB_TYPE = (); # registry for type (cf-object class) based events 709our @CB_TYPE = (); # registry for type (cf-object class) based events
504our @CB_MAP = (); 710our @CB_MAP = ();
505 711
506my %attachment; 712my %attachment;
507 713
714sub cf::attachable::thawer_merge {
715 # simply override everything except _meta
716 local $_[0]{_meta};
717 %{$_[0]} = %{$_[1]};
718}
719
508sub _attach_cb($$$$) { 720sub _attach_cb($$$$) {
509 my ($registry, $event, $prio, $cb) = @_; 721 my ($registry, $event, $prio, $cb) = @_;
510 722
511 use sort 'stable'; 723 use sort 'stable';
512 724
… …
546 $registry = $CB_TYPE[$object_type] ||= []; 758 $registry = $CB_TYPE[$object_type] ||= [];
547 759
548 } elsif ($type eq "subtype") { 760 } elsif ($type eq "subtype") {
549 defined $object_type or Carp::croak "subtype specified without type"; 761 defined $object_type or Carp::croak "subtype specified without type";
550 my $object_subtype = shift @arg; 762 my $object_subtype = shift @arg;
551 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 763 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
552 764
553 } elsif ($type eq "package") { 765 } elsif ($type eq "package") {
554 my $pkg = shift @arg; 766 my $pkg = shift @arg;
555 767
556 while (my ($name, $id) = each %cb_id) { 768 while (my ($name, $id) = each %cb_id) {
… …
585 _attach $registry, $klass, @attach; 797 _attach $registry, $klass, @attach;
586 } 798 }
587 799
588 $obj->{$name} = \%arg; 800 $obj->{$name} = \%arg;
589 } else { 801 } else {
590 warn "object uses attachment '$name' that is not available, postponing.\n"; 802 warn "object uses attachment '$name' which is not available, postponing.\n";
591 } 803 }
592 804
593 $obj->{_attachment}{$name} = undef; 805 $obj->{_attachment}{$name} = undef;
594} 806}
595 807
… …
597 if (ref $_[0]) { 809 if (ref $_[0]) {
598 _object_attach @_; 810 _object_attach @_;
599 } else { 811 } else {
600 _attach shift->_attach_registry, @_; 812 _attach shift->_attach_registry, @_;
601 } 813 }
814 _recalc_want;
602}; 815};
603 816
604# all those should be optimised 817# all those should be optimised
605sub cf::attachable::detach { 818sub cf::attachable::detach {
606 my ($obj, $name) = @_; 819 my ($obj, $name) = @_;
… …
609 delete $obj->{_attachment}{$name}; 822 delete $obj->{_attachment}{$name};
610 reattach ($obj); 823 reattach ($obj);
611 } else { 824 } else {
612 Carp::croak "cannot, currently, detach class attachments"; 825 Carp::croak "cannot, currently, detach class attachments";
613 } 826 }
827 _recalc_want;
614}; 828};
615 829
616sub cf::attachable::attached { 830sub cf::attachable::attached {
617 my ($obj, $name) = @_; 831 my ($obj, $name) = @_;
618 832
… …
683# object support 897# object support
684 898
685sub reattach { 899sub reattach {
686 # basically do the same as instantiate, without calling instantiate 900 # basically do the same as instantiate, without calling instantiate
687 my ($obj) = @_; 901 my ($obj) = @_;
902
903 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
688 904
689 my $registry = $obj->registry; 905 my $registry = $obj->registry;
690 906
691 @$registry = (); 907 @$registry = ();
692 908
… …
739 $filename, length $$rdata, scalar @$objs; 955 $filename, length $$rdata, scalar @$objs;
740 956
741 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 957 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
742 chmod SAVE_MODE, $fh; 958 chmod SAVE_MODE, $fh;
743 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 959 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
744 aio_fsync $fh; 960 aio_fsync $fh if $cf::USE_FSYNC;
745 close $fh; 961 close $fh;
746 962
747 if (@$objs) { 963 if (@$objs) {
748 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 964 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
749 chmod SAVE_MODE, $fh; 965 chmod SAVE_MODE, $fh;
750 my $data = Storable::nfreeze { version => 1, objs => $objs }; 966 my $data = Storable::nfreeze { version => 1, objs => $objs };
751 aio_write $fh, 0, (length $data), $data, 0; 967 aio_write $fh, 0, (length $data), $data, 0;
752 aio_fsync $fh; 968 aio_fsync $fh if $cf::USE_FSYNC;
753 close $fh; 969 close $fh;
754 aio_rename "$filename.pst~", "$filename.pst"; 970 aio_rename "$filename.pst~", "$filename.pst";
755 } 971 }
756 } else { 972 } else {
757 aio_unlink "$filename.pst"; 973 aio_unlink "$filename.pst";
… …
789 or return; 1005 or return;
790 $av = eval { (Storable::thaw $av)->{objs} }; 1006 $av = eval { (Storable::thaw $av)->{objs} };
791 } 1007 }
792 1008
793 warn sprintf "loading %s (%d)\n", 1009 warn sprintf "loading %s (%d)\n",
794 $filename, length $data, scalar @{$av || []};#d# 1010 $filename, length $data, scalar @{$av || []};
795 return ($data, $av); 1011 return ($data, $av);
796} 1012}
1013
1014=head2 COMMAND CALLBACKS
1015
1016=over 4
1017
1018=cut
797 1019
798############################################################################# 1020#############################################################################
799# command handling &c 1021# command handling &c
800 1022
801=item cf::register_command $name => \&callback($ob,$args); 1023=item cf::register_command $name => \&callback($ob,$args);
… …
814 push @{ $COMMAND{$name} }, [$caller, $cb]; 1036 push @{ $COMMAND{$name} }, [$caller, $cb];
815} 1037}
816 1038
817=item cf::register_extcmd $name => \&callback($pl,$packet); 1039=item cf::register_extcmd $name => \&callback($pl,$packet);
818 1040
819Register a callbackf ro execution when the client sends an extcmd packet. 1041Register a callback for execution when the client sends an (synchronous)
1042extcmd packet. Ext commands will be processed in the order they are
1043received by the server, like other user commands. The first argument is
1044the logged-in player. Ext commands can only be processed after a player
1045has logged in successfully.
820 1046
821If the callback returns something, it is sent back as if reply was being 1047If the callback returns something, it is sent back as if reply was being
822called. 1048called.
823 1049
1050=item cf::register_exticmd $name => \&callback($ns,$packet);
1051
1052Register a callback for execution when the client sends an (asynchronous)
1053exticmd packet. Exti commands are processed by the server as soon as they
1054are received, i.e. out of order w.r.t. other commands. The first argument
1055is a client socket. Exti commands can be received anytime, even before
1056log-in.
1057
1058If the callback returns something, it is sent back as if reply was being
1059called.
1060
824=cut 1061=cut
825 1062
826sub register_extcmd { 1063sub register_extcmd {
827 my ($name, $cb) = @_; 1064 my ($name, $cb) = @_;
828 1065
829 $EXTCMD{$name} = $cb; 1066 $EXTCMD{$name} = $cb;
1067}
1068
1069sub register_exticmd {
1070 my ($name, $cb) = @_;
1071
1072 $EXTICMD{$name} = $cb;
830} 1073}
831 1074
832cf::player->attach ( 1075cf::player->attach (
833 on_command => sub { 1076 on_command => sub {
834 my ($pl, $name, $params) = @_; 1077 my ($pl, $name, $params) = @_;
… …
843 cf::override; 1086 cf::override;
844 }, 1087 },
845 on_extcmd => sub { 1088 on_extcmd => sub {
846 my ($pl, $buf) = @_; 1089 my ($pl, $buf) = @_;
847 1090
848 my $msg = eval { from_json $buf }; 1091 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
849 1092
850 if (ref $msg) { 1093 if (ref $msg) {
851 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1094 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
852 if (my %reply = $cb->($pl, $msg)) { 1095 if (my %reply = $cb->($pl, $msg)) {
853 $pl->ext_reply ($msg->{msgid}, %reply); 1096 $pl->ext_reply ($msg->{msgid}, %reply);
… …
859 1102
860 cf::override; 1103 cf::override;
861 }, 1104 },
862); 1105);
863 1106
864sub load_extension {
865 my ($path) = @_;
866
867 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
868 my $base = $1;
869 my $pkg = $1;
870 $pkg =~ s/[^[:word:]]/_/g;
871 $pkg = "ext::$pkg";
872
873 warn "... loading '$path' into '$pkg'\n";
874
875 open my $fh, "<:utf8", $path
876 or die "$path: $!";
877
878 my $source =
879 "package $pkg; use strict; use utf8;\n"
880 . "#line 1 \"$path\"\n{\n"
881 . (do { local $/; <$fh> })
882 . "\n};\n1";
883
884 unless (eval $source) {
885 my $msg = $@ ? "$path: $@\n"
886 : "extension disabled.\n";
887 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
888 warn $@;
889 warn "mandatory extension failed to load, exiting.\n";
890 exit 1;
891 }
892 die $@;
893 }
894
895 push @EXTS, $pkg;
896}
897
898sub load_extensions { 1107sub load_extensions {
1108 cf::sync_job {
1109 my %todo;
1110
899 for my $ext (<$LIBDIR/*.ext>) { 1111 for my $path (<$LIBDIR/*.ext>) {
900 next unless -r $ext; 1112 next unless -r $path;
901 eval { 1113
902 load_extension $ext; 1114 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1115 my $base = $1;
1116 my $pkg = $1;
1117 $pkg =~ s/[^[:word:]]/_/g;
1118 $pkg = "ext::$pkg";
1119
1120 open my $fh, "<:utf8", $path
1121 or die "$path: $!";
1122
1123 my $source = do { local $/; <$fh> };
1124
1125 my %ext = (
1126 path => $path,
1127 base => $base,
1128 pkg => $pkg,
1129 );
1130
1131 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1132 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1133
1134 $ext{source} =
1135 "package $pkg; use strict; use utf8;\n"
1136 . "#line 1 \"$path\"\n{\n"
1137 . $source
1138 . "\n};\n1";
1139
1140 $todo{$base} = \%ext;
1141 }
1142
1143 my %done;
1144 while (%todo) {
1145 my $progress;
1146
1147 while (my ($k, $v) = each %todo) {
1148 for (split /,\s*/, $v->{meta}{depends}) {
1149 goto skip
1150 unless exists $done{$_};
1151 }
1152
1153 warn "... loading '$k' into '$v->{pkg}'\n";
1154
1155 unless (eval $v->{source}) {
1156 my $msg = $@ ? "$v->{path}: $@\n"
1157 : "$v->{base}: extension inactive.\n";
1158
1159 if (exists $v->{meta}{mandatory}) {
1160 warn $msg;
1161 warn "mandatory extension failed to load, exiting.\n";
1162 exit 1;
1163 }
1164
1165 warn $msg;
1166 }
1167
1168 $done{$k} = delete $todo{$k};
1169 push @EXTS, $v->{pkg};
1170 $progress = 1;
903 1 1171 }
904 } or warn "$ext not loaded: $@"; 1172
1173 skip:
1174 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1175 unless $progress;
1176 }
905 } 1177 };
906} 1178}
907 1179
908############################################################################# 1180#############################################################################
909 1181
1182=back
1183
910=head2 CORE EXTENSIONS 1184=head2 CORE EXTENSIONS
911 1185
912Functions and methods that extend core crossfire objects. 1186Functions and methods that extend core crossfire objects.
913 1187
914=cut 1188=cut
… …
926Returns the given player object, loading it if necessary (might block). 1200Returns the given player object, loading it if necessary (might block).
927 1201
928=cut 1202=cut
929 1203
930sub playerdir($) { 1204sub playerdir($) {
931 cf::localdir 1205 "$PLAYERDIR/"
932 . "/"
933 . cf::playerdir
934 . "/"
935 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1206 . (ref $_[0] ? $_[0]->ob->name : $_[0])
936} 1207}
937 1208
938sub path($) { 1209sub path($) {
939 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1210 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
940 1211
941 (playerdir $login) . "/$login.pl" 1212 (playerdir $login) . "/playerdata"
942} 1213}
943 1214
944sub find_active($) { 1215sub find_active($) {
945 $cf::PLAYER{$_[0]} 1216 $cf::PLAYER{$_[0]}
946 and $cf::PLAYER{$_[0]}->active 1217 and $cf::PLAYER{$_[0]}->active
… …
949 1220
950sub exists($) { 1221sub exists($) {
951 my ($login) = @_; 1222 my ($login) = @_;
952 1223
953 $cf::PLAYER{$login} 1224 $cf::PLAYER{$login}
954 or cf::sync_job { !aio_stat $login } 1225 or cf::sync_job { !aio_stat path $login }
955} 1226}
956 1227
957sub find($) { 1228sub find($) {
958 return $cf::PLAYER{$_[0]} || do { 1229 return $cf::PLAYER{$_[0]} || do {
959 my $login = $_[0]; 1230 my $login = $_[0];
960 1231
961 my $guard = cf::lock_acquire "user_find:$login"; 1232 my $guard = cf::lock_acquire "user_find:$login";
962 1233
963 $cf::PLAYER{$_[0]} || do { 1234 $cf::PLAYER{$_[0]} || do {
1235 # rename old playerfiles to new ones
1236 #TODO: remove when no longer required
1237 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1238 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1239 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1240 aio_unlink +(playerdir $login) . "/$login.pl";
1241
964 my $pl = load_pl path $login 1242 my $pl = load_pl path $login
965 or return; 1243 or return;
966 $cf::PLAYER{$login} = $pl 1244 $cf::PLAYER{$login} = $pl
967 } 1245 }
968 } 1246 }
… …
1005 1283
1006=cut 1284=cut
1007 1285
1008sub quit_character { 1286sub quit_character {
1009 my ($pl) = @_; 1287 my ($pl) = @_;
1288
1289 my $name = $pl->ob->name;
1010 1290
1011 $pl->{deny_save} = 1; 1291 $pl->{deny_save} = 1;
1012 $pl->password ("*"); # this should lock out the player until we nuked the dir 1292 $pl->password ("*"); # this should lock out the player until we nuked the dir
1013 1293
1014 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1294 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
… …
1019 my $path = playerdir $pl; 1299 my $path = playerdir $pl;
1020 my $temp = "$path~$cf::RUNTIME~deleting~"; 1300 my $temp = "$path~$cf::RUNTIME~deleting~";
1021 aio_rename $path, $temp; 1301 aio_rename $path, $temp;
1022 delete $cf::PLAYER{$pl->ob->name}; 1302 delete $cf::PLAYER{$pl->ob->name};
1023 $pl->destroy; 1303 $pl->destroy;
1304
1305 my $prefix = qr<^~\Q$name\E/>;
1306
1307 # nuke player maps
1308 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1309
1024 IO::AIO::aio_rmtree $temp; 1310 IO::AIO::aio_rmtree $temp;
1311}
1312
1313=item $pl->kick
1314
1315Kicks a player out of the game. This destroys the connection.
1316
1317=cut
1318
1319sub kick {
1320 my ($pl, $kicker) = @_;
1321
1322 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1323 $pl->killer ("kicked");
1324 $pl->ns->destroy;
1025} 1325}
1026 1326
1027=item cf::player::list_logins 1327=item cf::player::list_logins
1028 1328
1029Returns am arrayref of all valid playernames in the system, can take a 1329Returns am arrayref of all valid playernames in the system, can take a
1030while and may block, so not sync_job-capable, ever. 1330while and may block, so not sync_job-capable, ever.
1031 1331
1032=cut 1332=cut
1033 1333
1034sub list_logins { 1334sub list_logins {
1035 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1335 my $dirs = aio_readdir $PLAYERDIR
1036 or return []; 1336 or return [];
1037 1337
1038 my @logins; 1338 my @logins;
1039 1339
1040 for my $login (@$dirs) { 1340 for my $login (@$dirs) {
… …
1057=cut 1357=cut
1058 1358
1059sub maps($) { 1359sub maps($) {
1060 my ($pl) = @_; 1360 my ($pl) = @_;
1061 1361
1362 $pl = ref $pl ? $pl->ob->name : $pl;
1363
1062 my $files = aio_readdir playerdir $pl 1364 my $files = aio_readdir playerdir $pl
1063 or return; 1365 or return;
1064 1366
1065 my @paths; 1367 my @paths;
1066 1368
1067 for (@$files) { 1369 for (@$files) {
1068 utf8::decode $_; 1370 utf8::decode $_;
1069 next if /\.(?:pl|pst)$/; 1371 next if /\.(?:pl|pst)$/;
1070 next unless /^$PATH_SEP/o; 1372 next unless /^$PATH_SEP/o;
1071 1373
1072 s/\.map$//; 1374 push @paths, cf::map::normalise "~$pl/$_";
1073 push @paths, "~" . $pl->ob->name . "/" . $_;
1074 } 1375 }
1075 1376
1076 \@paths 1377 \@paths
1077} 1378}
1078 1379
1380=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1381
1382Expand crossfire pod fragments into protocol xml.
1383
1384=cut
1385
1386sub expand_cfpod {
1387 ((my $self), (local $_)) = @_;
1388
1389 # escape & and <
1390 s/&/&amp;/g;
1391 s/(?<![BIUGH])</&lt;/g;
1392
1393 # this is buggy, it needs to properly take care of nested <'s
1394
1395 1 while
1396 # replace B<>, I<>, U<> etc.
1397 s/B<([^\>]*)>/<b>$1<\/b>/
1398 || s/I<([^\>]*)>/<i>$1<\/i>/
1399 || s/U<([^\>]*)>/<u>$1<\/u>/
1400 # replace G<male|female> tags
1401 || s{G<([^>|]*)\|([^>]*)>}{
1402 $self->gender ? $2 : $1
1403 }ge
1404 # replace H<hint text>
1405 || s{H<([^\>]*)>}
1406 {
1407 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1408 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1409 "")
1410 [$self->{hintmode}]
1411 }ge;
1412
1413 # create single paragraphs (very hackish)
1414 s/(?<=\S)\n(?=\w)/ /g;
1415
1416 # compress some whitespace
1417 1 while s/\s*\n\s*\n\s*/\n/;
1418
1419 $_
1420}
1421
1422sub hintmode {
1423 warn "hm<$_[0] $_[1]>\n";#d#
1424 $_[0]{hintmode} = $_[1] if @_ > 1;
1425 $_[0]{hintmode}
1426}
1427
1079=item $player->ext_reply ($msgid, $msgtype, %msg) 1428=item $player->ext_reply ($msgid, %msg)
1080 1429
1081Sends an ext reply to the player. 1430Sends an ext reply to the player.
1082 1431
1083=cut 1432=cut
1084 1433
1085sub ext_reply($$$%) { 1434sub ext_reply($$%) {
1086 my ($self, $id, %msg) = @_; 1435 my ($self, $id, %msg) = @_;
1087 1436
1088 $msg{msgid} = $id; 1437 $msg{msgid} = $id;
1089 1438 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1090 $self->send ("ext " . cf::to_json \%msg);
1091} 1439}
1092 1440
1093package cf; 1441=item $player->ext_event ($type, %msg)
1442
1443Sends an ext event to the client.
1444
1445=cut
1446
1447sub ext_event($$%) {
1448 my ($self, $type, %msg) = @_;
1449
1450 $self->ns->ext_event ($type, %msg);
1451}
1452
1453=head3 cf::region
1454
1455=over 4
1456
1457=cut
1458
1459package cf::region;
1460
1461=item cf::region::find_by_path $path
1462
1463Tries to decuce the likely region for a map knowing only its path.
1464
1465=cut
1466
1467sub find_by_path($) {
1468 my ($path) = @_;
1469
1470 my ($match, $specificity);
1471
1472 for my $region (list) {
1473 if ($region->match && $path =~ $region->match) {
1474 ($match, $specificity) = ($region, $region->specificity)
1475 if $region->specificity > $specificity;
1476 }
1477 }
1478
1479 $match
1480}
1094 1481
1095=back 1482=back
1096
1097 1483
1098=head3 cf::map 1484=head3 cf::map
1099 1485
1100=over 4 1486=over 4
1101 1487
… …
1105 1491
1106use Fcntl; 1492use Fcntl;
1107use Coro::AIO; 1493use Coro::AIO;
1108 1494
1109use overload 1495use overload
1110 '""' => \&as_string; 1496 '""' => \&as_string,
1497 fallback => 1;
1111 1498
1112our $MAX_RESET = 3600; 1499our $MAX_RESET = 3600;
1113our $DEFAULT_RESET = 3000; 1500our $DEFAULT_RESET = 3000;
1114 1501
1115sub generate_random_map { 1502sub generate_random_map {
1116 my ($self, $rmp) = @_; 1503 my ($self, $rmp) = @_;
1117
1118 # mit "rum" bekleckern, nicht 1504 # mit "rum" bekleckern, nicht
1119 $self->_create_random_map ( 1505 $self->_create_random_map (
1120 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1506 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1121 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1507 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1122 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1508 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1129 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1515 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1130 (cf::region::find $rmp->{region}), $rmp->{custom} 1516 (cf::region::find $rmp->{region}), $rmp->{custom}
1131 ) 1517 )
1132} 1518}
1133 1519
1520=item cf::map->register ($regex, $prio)
1521
1522Register a handler for the map path matching the given regex at the
1523givne priority (higher is better, built-in handlers have priority 0, the
1524default).
1525
1526=cut
1527
1134sub register { 1528sub register {
1135 my (undef, $regex) = @_; 1529 my (undef, $regex, $prio) = @_;
1136 my $pkg = caller; 1530 my $pkg = caller;
1137 1531
1138 no strict; 1532 no strict;
1139 push @{"$pkg\::ISA"}, __PACKAGE__; 1533 push @{"$pkg\::ISA"}, __PACKAGE__;
1140 1534
1141 $EXT_MAP{$pkg} = qr<$regex>; 1535 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1142} 1536}
1143 1537
1144# also paths starting with '/' 1538# also paths starting with '/'
1145$EXT_MAP{"cf::map"} = qr{^(?=/)}; 1539$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1540
1541sub thawer_merge {
1542 my ($self, $merge) = @_;
1543
1544 # we have to keep some variables in memory intact
1545 local $self->{path};
1546 local $self->{load_path};
1547
1548 $self->SUPER::thawer_merge ($merge);
1549}
1146 1550
1147sub normalise { 1551sub normalise {
1148 my ($path, $base) = @_; 1552 my ($path, $base) = @_;
1553
1554 $path = "$path"; # make sure its a string
1555
1556 $path =~ s/\.map$//;
1149 1557
1150 # map plan: 1558 # map plan:
1151 # 1559 #
1152 # /! non-realised random map exit (special hack!) 1560 # /! non-realised random map exit (special hack!)
1153 # {... are special paths that are not being touched 1561 # {... are special paths that are not being touched
… …
1181 1589
1182 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object 1590 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1183 1591
1184 $path = normalise $path, $base; 1592 $path = normalise $path, $base;
1185 1593
1186 for my $pkg (keys %EXT_MAP) { 1594 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1187 if ($path =~ $EXT_MAP{$pkg}) { 1595 if ($path =~ $EXT_MAP{$pkg}[1]) {
1188 my $self = bless cf::map::new, $pkg; 1596 my $self = bless cf::map::new, $pkg;
1189 $self->{path} = $path; $self->path ($path); 1597 $self->{path} = $path; $self->path ($path);
1190 $self->init; # pass $1 etc. 1598 $self->init; # pass $1 etc.
1191 return $self; 1599 return $self;
1192 } 1600 }
1193 } 1601 }
1194 1602
1195 Carp::carp "unable to resolve path '$path'."; 1603 Carp::carp "unable to resolve path '$path' (base '$base').";
1196 () 1604 ()
1197} 1605}
1198 1606
1199sub init { 1607sub init {
1200 my ($self) = @_; 1608 my ($self) = @_;
… …
1215 1623
1216# the original (read-only) location 1624# the original (read-only) location
1217sub load_path { 1625sub load_path {
1218 my ($self) = @_; 1626 my ($self) = @_;
1219 1627
1220 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path} 1628 "$MAPDIR/$self->{path}.map"
1221} 1629}
1222 1630
1223# the temporary/swap location 1631# the temporary/swap location
1224sub save_path { 1632sub save_path {
1225 my ($self) = @_; 1633 my ($self) = @_;
1226 1634
1227 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1635 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1228 sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $path 1636 "$TMPDIR/$path.map"
1229} 1637}
1230 1638
1231# the unique path, undef == no special unique path 1639# the unique path, undef == no special unique path
1232sub uniq_path { 1640sub uniq_path {
1233 my ($self) = @_; 1641 my ($self) = @_;
1234 1642
1235 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1643 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1236 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1644 "$UNIQUEDIR/$path"
1237} 1645}
1238 1646
1239# and all this just because we cannot iterate over 1647# and all this just because we cannot iterate over
1240# all maps in C++... 1648# all maps in C++...
1241sub change_all_map_light { 1649sub change_all_map_light {
… …
1243 1651
1244 $_->change_map_light ($change) 1652 $_->change_map_light ($change)
1245 for grep $_->outdoor, values %cf::MAP; 1653 for grep $_->outdoor, values %cf::MAP;
1246} 1654}
1247 1655
1656sub decay_objects {
1657 my ($self) = @_;
1658
1659 return if $self->{deny_reset};
1660
1661 $self->do_decay_objects;
1662}
1663
1248sub unlink_save { 1664sub unlink_save {
1249 my ($self) = @_; 1665 my ($self) = @_;
1250 1666
1251 utf8::encode (my $save = $self->save_path); 1667 utf8::encode (my $save = $self->save_path);
1252 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink $save; 1668 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1253 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink "$save.pst"; 1669 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1254} 1670}
1255 1671
1256sub load_header_from($) { 1672sub load_header_from($) {
1257 my ($self, $path) = @_; 1673 my ($self, $path) = @_;
1258 1674
1259 utf8::encode $path; 1675 utf8::encode $path;
1260 aio_open $path, O_RDONLY, 0 1676 #aio_open $path, O_RDONLY, 0
1261 or return; 1677 # or return;
1262 1678
1263 $self->_load_header ($path) 1679 $self->_load_header ($path)
1264 or return; 1680 or return;
1265 1681
1266 $self->{load_path} = $path; 1682 $self->{load_path} = $path;
1267 1683
1268 1 1684 1
1269} 1685}
1270 1686
1271sub load_orig { 1687sub load_header_orig {
1272 my ($self) = @_; 1688 my ($self) = @_;
1273 1689
1274 $self->load_header_from ($self->load_path) 1690 $self->load_header_from ($self->load_path)
1275} 1691}
1276 1692
1277sub load_temp { 1693sub load_header_temp {
1278 my ($self) = @_; 1694 my ($self) = @_;
1279 1695
1280 $self->load_header_from ($self->save_path) 1696 $self->load_header_from ($self->save_path)
1697}
1698
1699sub prepare_temp {
1700 my ($self) = @_;
1701
1702 $self->last_access ((delete $self->{last_access})
1703 || $cf::RUNTIME); #d#
1704 # safety
1705 $self->{instantiate_time} = $cf::RUNTIME
1706 if $self->{instantiate_time} > $cf::RUNTIME;
1707}
1708
1709sub prepare_orig {
1710 my ($self) = @_;
1711
1712 $self->{load_original} = 1;
1713 $self->{instantiate_time} = $cf::RUNTIME;
1714 $self->last_access ($cf::RUNTIME);
1715 $self->instantiate;
1281} 1716}
1282 1717
1283sub load_header { 1718sub load_header {
1284 my ($self) = @_; 1719 my ($self) = @_;
1285 1720
1286 if ($self->load_temp) { 1721 if ($self->load_header_temp) {
1287 $self->last_access ((delete $self->{last_access}) 1722 $self->prepare_temp;
1288 || $cf::RUNTIME); #d#
1289 # safety
1290 $self->{instantiate_time} = $cf::RUNTIME
1291 if $self->{instantiate_time} > $cf::RUNTIME;
1292 } else { 1723 } else {
1293 $self->load_orig 1724 $self->load_header_orig
1294 or return; 1725 or return;
1295 1726 $self->prepare_orig;
1296 $self->{load_original} = 1;
1297 $self->{instantiate_time} = $cf::RUNTIME;
1298 $self->last_access ($cf::RUNTIME);
1299 $self->instantiate;
1300 } 1727 }
1728
1729 $self->{deny_reset} = 1
1730 if $self->no_reset;
1731
1732 $self->default_region (cf::region::find_by_path $self->{path})
1733 unless $self->default_region;
1301 1734
1302 1 1735 1
1303} 1736}
1304 1737
1305sub find; 1738sub find;
… …
1318 $map->{last_save} = $cf::RUNTIME; 1751 $map->{last_save} = $cf::RUNTIME;
1319 1752
1320 $map->load_header 1753 $map->load_header
1321 or return; 1754 or return;
1322 1755
1323 if ($map->should_reset) { 1756 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1757 # doing this can freeze the server in a sync job, obviously
1758 #$cf::WAIT_FOR_TICK->wait;
1324 $map->reset; 1759 $map->reset;
1325 undef $guard; 1760 undef $guard;
1326 $map = find $path 1761 return find $path;
1327 or return;
1328 } 1762 }
1329 1763
1330 $cf::MAP{$path} = $map 1764 $cf::MAP{$path} = $map
1331 } 1765 }
1332} 1766}
1767
1768sub pre_load { }
1769sub post_load { }
1333 1770
1334sub load { 1771sub load {
1335 my ($self) = @_; 1772 my ($self) = @_;
1336 1773
1774 local $self->{deny_reset} = 1; # loading can take a long time
1775
1337 my $path = $self->{path}; 1776 my $path = $self->{path};
1777
1778 {
1338 my $guard = cf::lock_acquire "map_load:$path"; 1779 my $guard = cf::lock_acquire "map_load:$path";
1339 1780
1340 return if $self->in_memory != cf::MAP_SWAPPED; 1781 return if $self->in_memory != cf::MAP_SWAPPED;
1341 1782
1342 $self->in_memory (cf::MAP_LOADING); 1783 $self->in_memory (cf::MAP_LOADING);
1343 1784
1344 $self->alloc; 1785 $self->alloc;
1345 $self->_load_objects ($self->{load_path}, 1)
1346 or return;
1347 1786
1348 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1787 $self->pre_load;
1349 if delete $self->{load_original};
1350
1351 if (my $uniq = $self->uniq_path) {
1352 utf8::encode $uniq;
1353 if (aio_open $uniq, O_RDONLY, 0) {
1354 $self->clear_unique_items;
1355 $self->_load_objects ($uniq, 0);
1356 }
1357 }
1358
1359 Coro::cede;
1360
1361 # now do the right thing for maps
1362 $self->link_multipart_objects;
1363
1364 unless ($self->{deny_activate}) {
1365 $self->decay_objects;
1366 $self->fix_auto_apply;
1367 $self->update_buttons;
1368 Coro::cede; 1788 Coro::cede;
1369 $self->set_darkness_map; 1789
1790 $self->_load_objects ($self->{load_path}, 1)
1791 or return;
1792
1793 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1794 if delete $self->{load_original};
1795
1796 if (my $uniq = $self->uniq_path) {
1797 utf8::encode $uniq;
1798 if (aio_open $uniq, O_RDONLY, 0) {
1799 $self->clear_unique_items;
1800 $self->_load_objects ($uniq, 0);
1801 }
1802 }
1803
1804 Coro::cede;
1805 # now do the right thing for maps
1806 $self->link_multipart_objects;
1370 $self->difficulty ($self->estimate_difficulty) 1807 $self->difficulty ($self->estimate_difficulty)
1371 unless $self->difficulty; 1808 unless $self->difficulty;
1372 Coro::cede; 1809 Coro::cede;
1810
1811 unless ($self->{deny_activate}) {
1812 $self->decay_objects;
1813 $self->fix_auto_apply;
1814 $self->update_buttons;
1815 Coro::cede;
1816 $self->set_darkness_map;
1817 Coro::cede;
1373 $self->activate; 1818 $self->activate;
1374 } 1819 }
1375 1820
1376 $self->in_memory (cf::MAP_IN_MEMORY); 1821 $self->in_memory (cf::MAP_IN_MEMORY);
1822 }
1823
1824 $self->post_load;
1377} 1825}
1378 1826
1379sub customise_for { 1827sub customise_for {
1380 my ($self, $ob) = @_; 1828 my ($self, $ob) = @_;
1381 1829
1382 return find "~" . $ob->name . "/" . $self->{path} 1830 return find "~" . $ob->name . "/" . $self->{path}
1383 if $self->per_player; 1831 if $self->per_player;
1832
1833# return find "?party/" . $ob->name . "/" . $self->{path}
1834# if $self->per_party;
1384 1835
1385 $self 1836 $self
1386} 1837}
1387 1838
1388# find and load all maps in the 3x3 area around a map 1839# find and load all maps in the 3x3 area around a map
… …
1420 1871
1421 cf::sync_job { $map->load }; 1872 cf::sync_job { $map->load };
1422} 1873}
1423 1874
1424our %MAP_PREFETCH; 1875our %MAP_PREFETCH;
1425our $MAP_PREFETCHER = Coro::async { 1876our $MAP_PREFETCHER = undef;
1426 while () {
1427 for my $path (keys %MAP_PREFETCH) {
1428 my $map = find $path
1429 or next;
1430 $map->load;
1431
1432 delete $MAP_PREFETCH{$path};
1433 }
1434 Coro::schedule;
1435 }
1436};
1437 1877
1438sub find_async { 1878sub find_async {
1439 my ($path, $origin) = @_; 1879 my ($path, $origin) = @_;
1440 1880
1441 $path = normalise $path, $origin && $origin->{path}; 1881 $path = normalise $path, $origin && $origin->{path};
1442 1882
1443 if (my $map = $cf::MAP{$path}) { 1883 if (my $map = $cf::MAP{$path}) {
1444 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 1884 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1445 } 1885 }
1446 1886
1447 $MAP_PREFETCH{$path} = 0; 1887 undef $MAP_PREFETCH{$path};
1888 $MAP_PREFETCHER ||= cf::async {
1889 while (%MAP_PREFETCH) {
1890 for my $path (keys %MAP_PREFETCH) {
1891 my $map = find $path
1892 or next;
1893 $map->load;
1894
1895 delete $MAP_PREFETCH{$path};
1896 }
1897 }
1898 undef $MAP_PREFETCHER;
1899 };
1448 $MAP_PREFETCHER->ready; 1900 $MAP_PREFETCHER->prio (6);
1449 1901
1450 () 1902 ()
1451} 1903}
1452 1904
1453sub save { 1905sub save {
… …
1498 1950
1499sub reset_at { 1951sub reset_at {
1500 my ($self) = @_; 1952 my ($self) = @_;
1501 1953
1502 # TODO: safety, remove and allow resettable per-player maps 1954 # TODO: safety, remove and allow resettable per-player maps
1503 return 1e99 if $self->isa ("ext::map_per_player");
1504 return 1e99 if $self->{deny_reset}; 1955 return 1e99 if $self->{deny_reset};
1505 1956
1506 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1957 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1507 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1958 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1508 1959
… …
1513 my ($self) = @_; 1964 my ($self) = @_;
1514 1965
1515 $self->reset_at <= $cf::RUNTIME 1966 $self->reset_at <= $cf::RUNTIME
1516} 1967}
1517 1968
1518sub rename {
1519 my ($self, $new_path) = @_;
1520
1521 normalise $new_path;
1522
1523 $self->unlink_save;
1524
1525 delete $cf::MAP{$self->path};
1526 $self->{path} = $new_path; $self->path ($self->{path});
1527 $cf::MAP{$self->path} = $self;
1528
1529 $self->save;
1530}
1531
1532sub reset { 1969sub reset {
1533 my ($self) = @_; 1970 my ($self) = @_;
1534 1971
1535 my $lock = cf::lock_acquire "map_data:$self->{path}"; 1972 my $lock = cf::lock_acquire "map_data:$self->{path}";
1536 1973
1537 return if $self->players; 1974 return if $self->players;
1538 return if $self->isa ("ext::map_per_player");#d#
1539 1975
1540 warn "resetting map ", $self->path;#d# 1976 warn "resetting map ", $self->path;
1977
1978 $self->in_memory (cf::MAP_SWAPPED);
1979
1980 # need to save uniques path
1981 unless ($self->{deny_save}) {
1982 my $uniq = $self->uniq_path; utf8::encode $uniq;
1983
1984 $self->_save_objects ($uniq, cf::IO_UNIQUES)
1985 if $uniq;
1986 }
1541 1987
1542 delete $cf::MAP{$self->path}; 1988 delete $cf::MAP{$self->path};
1543 1989
1544 $self->in_memory (cf::MAP_SWAPPED);
1545 $self->clear; 1990 $self->clear;
1546 1991
1547 $_->clear_links_to ($self) for values %cf::MAP; 1992 $_->clear_links_to ($self) for values %cf::MAP;
1548 1993
1549 $self->unlink_save; 1994 $self->unlink_save;
… …
1553my $nuke_counter = "aaaa"; 1998my $nuke_counter = "aaaa";
1554 1999
1555sub nuke { 2000sub nuke {
1556 my ($self) = @_; 2001 my ($self) = @_;
1557 2002
2003 delete $cf::MAP{$self->path};
2004
2005 $self->unlink_save;
2006
2007 bless $self, "cf::map";
2008 delete $self->{deny_reset};
1558 $self->{deny_save} = 1; 2009 $self->{deny_save} = 1;
1559 $self->reset_timeout (1); 2010 $self->reset_timeout (1);
1560 $self->rename ("{nuke}/" . ($nuke_counter++)); 2011 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2012
2013 $cf::MAP{$self->path} = $self;
2014
1561 $self->reset; # polite request, might not happen 2015 $self->reset; # polite request, might not happen
2016}
2017
2018=item $maps = cf::map::tmp_maps
2019
2020Returns an arrayref with all map paths of currently instantiated and saved
2021maps. May block.
2022
2023=cut
2024
2025sub tmp_maps() {
2026 [
2027 map {
2028 utf8::decode $_;
2029 /\.map$/
2030 ? normalise $_
2031 : ()
2032 } @{ aio_readdir $TMPDIR or [] }
2033 ]
2034}
2035
2036=item $maps = cf::map::random_maps
2037
2038Returns an arrayref with all map paths of currently instantiated and saved
2039random maps. May block.
2040
2041=cut
2042
2043sub random_maps() {
2044 [
2045 map {
2046 utf8::decode $_;
2047 /\.map$/
2048 ? normalise "?random/$_"
2049 : ()
2050 } @{ aio_readdir $RANDOMDIR or [] }
2051 ]
1562} 2052}
1563 2053
1564=item cf::map::unique_maps 2054=item cf::map::unique_maps
1565 2055
1566Returns an arrayref of paths of all shared maps that have 2056Returns an arrayref of paths of all shared maps that have
1567instantiated unique items. May block. 2057instantiated unique items. May block.
1568 2058
1569=cut 2059=cut
1570 2060
1571sub unique_maps() { 2061sub unique_maps() {
1572 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2062 [
1573 or return; 2063 map {
1574
1575 my @paths;
1576
1577 for (@$files) {
1578 utf8::decode $_; 2064 utf8::decode $_;
1579 next if /\.pst$/;
1580 next unless /^$PATH_SEP/o;
1581
1582 s/\.map$//; 2065 /\.map$/
1583 push @paths, $_; 2066 ? normalise $_
2067 : ()
2068 } @{ aio_readdir $UNIQUEDIR or [] }
1584 } 2069 ]
1585
1586 \@paths
1587} 2070}
1588 2071
1589package cf; 2072package cf;
1590 2073
1591=back 2074=back
… …
1637 2120
1638 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2121 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1639 2122
1640 if ($self->{record_replies}) { 2123 if ($self->{record_replies}) {
1641 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2124 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2125
1642 } else { 2126 } else {
2127 my $pl = $self->contr;
2128
2129 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2130 my $diag = $pl->{npc_dialog};
2131 $diag->{pl}->ext_reply (
2132 $diag->{id},
2133 msgtype => "reply",
2134 msg => $diag->{pl}->expand_cfpod ($msg),
2135 add_topics => []
2136 );
2137
2138 } else {
1643 $msg = $npc->name . " says: $msg" if $npc; 2139 $msg = $npc->name . " says: $msg" if $npc;
1644 $self->message ($msg, $flags); 2140 $self->message ($msg, $flags);
2141 }
1645 } 2142 }
1646} 2143}
1647 2144
1648=item $player_object->may ("access") 2145=item $player_object->may ("access")
1649 2146
… …
1682=cut 2179=cut
1683 2180
1684sub link_map { 2181sub link_map {
1685 unless ($LINK_MAP) { 2182 unless ($LINK_MAP) {
1686 $LINK_MAP = cf::map::find "{link}" 2183 $LINK_MAP = cf::map::find "{link}"
1687 or do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 }; 2184 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1688 $LINK_MAP->load; 2185 $LINK_MAP->load;
1689 } 2186 }
1690 2187
1691 $LINK_MAP 2188 $LINK_MAP
1692} 2189}
… …
1697 $self->deactivate_recursive; 2194 $self->deactivate_recursive;
1698 2195
1699 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2196 return if UNIVERSAL::isa $self->map, "ext::map_link";
1700 2197
1701 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2198 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1702 if $self->map; 2199 if $self->map && $self->map->{path} ne "{link}";
1703 2200
1704 $self->enter_map ($LINK_MAP || link_map, 20, 20); 2201 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1705} 2202}
1706 2203
1707sub cf::object::player::leave_link { 2204sub cf::object::player::leave_link {
1708 my ($self, $map, $x, $y) = @_; 2205 my ($self, $map, $x, $y) = @_;
2206
2207 return unless $self->contr->active;
1709 2208
1710 my $link_pos = delete $self->{_link_pos}; 2209 my $link_pos = delete $self->{_link_pos};
1711 2210
1712 unless ($map) { 2211 unless ($map) {
1713 # restore original map position 2212 # restore original map position
… …
1731 $map->load; 2230 $map->load;
1732 $map->load_diag; 2231 $map->load_diag;
1733 2232
1734 return unless $self->contr->active; 2233 return unless $self->contr->active;
1735 $self->activate_recursive; 2234 $self->activate_recursive;
2235
2236 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1736 $self->enter_map ($map, $x, $y); 2237 $self->enter_map ($map, $x, $y);
1737} 2238}
1738 2239
1739cf::player->attach (
1740 on_logout => sub {
1741 my ($pl) = @_;
1742
1743 # abort map switching before logout
1744 if ($pl->ob->{_link_pos}) {
1745 cf::sync_job {
1746 $pl->ob->leave_link
1747 };
1748 }
1749 },
1750 on_login => sub {
1751 my ($pl) = @_;
1752
1753 # try to abort aborted map switching on player login :)
1754 # should happen only on crashes
1755 if ($pl->ob->{_link_pos}) {
1756 $pl->ob->enter_link;
1757 (async {
1758 # we need this sleep as the login has a concurrent enter_exit running
1759 # and this sleep increases chances of the player not ending up in scorn
1760 $pl->ob->reply (undef,
1761 "There was an internal problem at your last logout, "
1762 . "the server will try to bring you to your intended destination in a second.",
1763 cf::NDI_RED);
1764 Coro::Timer::sleep 1;
1765 $pl->ob->leave_link;
1766 })->prio (2);
1767 }
1768 },
1769);
1770
1771=item $player_object->goto ($path, $x, $y) 2240=item $player_object->goto ($path, $x, $y[, $check->($map)])
1772 2241
2242Moves the player to the given map-path and coordinates by first freezing
2243her, loading and preparing them map, calling the provided $check callback
2244that has to return the map if sucecssful, and then unfreezes the player on
2245the new (success) or old (failed) map position.
2246
1773=cut 2247=cut
2248
2249our $GOTOGEN;
1774 2250
1775sub cf::object::player::goto { 2251sub cf::object::player::goto {
1776 my ($self, $path, $x, $y) = @_; 2252 my ($self, $path, $x, $y, $check) = @_;
2253
2254 # do generation counting so two concurrent goto's will be executed in-order
2255 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1777 2256
1778 $self->enter_link; 2257 $self->enter_link;
1779 2258
1780 (async { 2259 (async {
2260 my $map = eval {
1781 my $map = cf::map::find $path; 2261 my $map = cf::map::find $path;
2262
2263 if ($map) {
1782 $map = $map->customise_for ($self) if $map; 2264 $map = $map->customise_for ($self);
1783 2265 $map = $check->($map) if $check && $map;
1784# warn "entering ", $map->path, " at ($x, $y)\n" 2266 } else {
1785# if $map;
1786
1787 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2267 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2268 }
1788 2269
2270 $map
2271 };
2272
2273 if ($@) {
2274 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2275 LOG llevError | logBacktrace, Carp::longmess $@;
2276 }
2277
2278 if ($gen == $self->{_goto_generation}) {
2279 delete $self->{_goto_generation};
1789 $self->leave_link ($map, $x, $y); 2280 $self->leave_link ($map, $x, $y);
2281 }
1790 })->prio (1); 2282 })->prio (1);
1791} 2283}
1792 2284
1793=item $player_object->enter_exit ($exit_object) 2285=item $player_object->enter_exit ($exit_object)
1794 2286
… …
1796 2288
1797sub parse_random_map_params { 2289sub parse_random_map_params {
1798 my ($spec) = @_; 2290 my ($spec) = @_;
1799 2291
1800 my $rmp = { # defaults 2292 my $rmp = { # defaults
1801 xsize => 10, 2293 xsize => (cf::rndm 15, 40),
1802 ysize => 10, 2294 ysize => (cf::rndm 15, 40),
2295 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2296 #layout => string,
1803 }; 2297 };
1804 2298
1805 for (split /\n/, $spec) { 2299 for (split /\n/, $spec) {
1806 my ($k, $v) = split /\s+/, $_, 2; 2300 my ($k, $v) = split /\s+/, $_, 2;
1807 2301
… …
1811 $rmp 2305 $rmp
1812} 2306}
1813 2307
1814sub prepare_random_map { 2308sub prepare_random_map {
1815 my ($exit) = @_; 2309 my ($exit) = @_;
2310
2311 my $guard = cf::lock_acquire "exit_prepare:$exit";
1816 2312
1817 # all this does is basically replace the /! path by 2313 # all this does is basically replace the /! path by
1818 # a new random map path (?random/...) with a seed 2314 # a new random map path (?random/...) with a seed
1819 # that depends on the exit object 2315 # that depends on the exit object
1820 2316
1821 my $rmp = parse_random_map_params $exit->msg; 2317 my $rmp = parse_random_map_params $exit->msg;
1822 2318
1823 if ($exit->map) { 2319 if ($exit->map) {
1824 $rmp->{region} = $exit->map->region_name; 2320 $rmp->{region} = $exit->region->name;
1825 $rmp->{origin_map} = $exit->map->path; 2321 $rmp->{origin_map} = $exit->map->path;
1826 $rmp->{origin_x} = $exit->x; 2322 $rmp->{origin_x} = $exit->x;
1827 $rmp->{origin_y} = $exit->y; 2323 $rmp->{origin_y} = $exit->y;
1828 } 2324 }
1829 2325
1830 $rmp->{random_seed} ||= $exit->random_seed; 2326 $rmp->{random_seed} ||= $exit->random_seed;
1831 2327
1832 my $data = cf::to_json $rmp; 2328 my $data = cf::to_json $rmp;
1833 my $md5 = Digest::MD5::md5_hex $data; 2329 my $md5 = Digest::MD5::md5_hex $data;
2330 my $meta = "$RANDOMDIR/$md5.meta";
1834 2331
1835 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) { 2332 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1836 aio_write $fh, 0, (length $data), $data, 0; 2333 aio_write $fh, 0, (length $data), $data, 0;
2334 undef $fh;
2335 aio_rename "$meta~", $meta;
1837 2336
1838 $exit->slaying ("?random/$md5"); 2337 $exit->slaying ("?random/$md5");
1839 $exit->msg (undef); 2338 $exit->msg (undef);
1840 } 2339 }
1841} 2340}
1842 2341
1843sub cf::object::player::enter_exit { 2342sub cf::object::player::enter_exit {
1844 my ($self, $exit) = @_; 2343 my ($self, $exit) = @_;
1845 2344
1846 return unless $self->type == cf::PLAYER; 2345 return unless $self->type == cf::PLAYER;
2346
2347 if ($exit->slaying eq "/!") {
2348 #TODO: this should de-fi-ni-te-ly not be a sync-job
2349 # the problem is that $exit might not survive long enough
2350 # so it needs to be done right now, right here
2351 cf::sync_job { prepare_random_map $exit };
2352 }
2353
2354 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2355 my $hp = $exit->stats->hp;
2356 my $sp = $exit->stats->sp;
1847 2357
1848 $self->enter_link; 2358 $self->enter_link;
1849 2359
1850 (async { 2360 (async {
1851 $self->deactivate_recursive; # just to be sure 2361 $self->deactivate_recursive; # just to be sure
1852 unless (eval { 2362 unless (eval {
1853 prepare_random_map $exit 2363 $self->goto ($slaying, $hp, $sp);
1854 if $exit->slaying eq "/!";
1855
1856 my $path = new_from_path cf::map $exit->slaying, $exit->map && $exit->map->path;
1857 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1858 2364
1859 1; 2365 1;
1860 }) { 2366 }) {
1861 $self->message ("Something went wrong deep within the crossfire server. " 2367 $self->message ("Something went wrong deep within the crossfire server. "
1862 . "I'll try to bring you back to the map you were before. " 2368 . "I'll try to bring you back to the map you were before. "
1863 . "Please report this to the dungeon master!", 2369 . "Please report this to the dungeon master!",
1864 cf::NDI_UNIQUE | cf::NDI_RED); 2370 cf::NDI_UNIQUE | cf::NDI_RED);
1865 2371
1866 warn "ERROR in enter_exit: $@"; 2372 warn "ERROR in enter_exit: $@";
1867 $self->leave_link; 2373 $self->leave_link;
1868 } 2374 }
1869 })->prio (1); 2375 })->prio (1);
… …
1882 2388
1883sub cf::client::send_drawinfo { 2389sub cf::client::send_drawinfo {
1884 my ($self, $text, $flags) = @_; 2390 my ($self, $text, $flags) = @_;
1885 2391
1886 utf8::encode $text; 2392 utf8::encode $text;
1887 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2393 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1888} 2394}
1889 2395
2396=item $client->send_msg ($color, $type, $msg, [extra...])
2397
2398Send a drawinfo or msg packet to the client, formatting the msg for the
2399client if neccessary. C<$type> should be a string identifying the type of
2400the message, with C<log> being the default. If C<$color> is negative, suppress
2401the message unless the client supports the msg packet.
2402
2403=cut
2404
2405sub cf::client::send_msg {
2406 my ($self, $color, $type, $msg, @extra) = @_;
2407
2408 $msg = $self->pl->expand_cfpod ($msg);
2409
2410 if ($self->can_msg) {
2411 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));
2412 } else {
2413 # replace some tags by gcfclient-compatible ones
2414 for ($msg) {
2415 1 while
2416 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2417 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2418 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2419 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2420 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2421 }
2422
2423 if ($color >= 0) {
2424 if (0 && $msg =~ /\[/) {
2425 $self->send_packet ("drawextinfo $color 4 0 $msg")
2426 } else {
2427 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2428 $self->send_packet ("drawinfo $color $msg")
2429 }
2430 }
2431 }
2432}
2433
2434=item $client->ext_event ($type, %msg)
2435
2436Sends an ext event to the client.
2437
2438=cut
2439
2440sub cf::client::ext_event($$%) {
2441 my ($self, $type, %msg) = @_;
2442
2443 $msg{msgtype} = "event_$type";
2444 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2445}
1890 2446
1891=item $success = $client->query ($flags, "text", \&cb) 2447=item $success = $client->query ($flags, "text", \&cb)
1892 2448
1893Queues a query to the client, calling the given callback with 2449Queues a query to the client, calling the given callback with
1894the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2450the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1895C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2451C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1896 2452
1897Queries can fail, so check the return code. Or don't, as queries will become 2453Queries can fail, so check the return code. Or don't, as queries will
1898reliable at some point in the future. 2454become reliable at some point in the future.
1899 2455
1900=cut 2456=cut
1901 2457
1902sub cf::client::query { 2458sub cf::client::query {
1903 my ($self, $flags, $text, $cb) = @_; 2459 my ($self, $flags, $text, $cb) = @_;
… …
1911 utf8::encode $text; 2467 utf8::encode $text;
1912 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2468 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1913 2469
1914 $self->send_packet ($self->{query_queue}[0][0]) 2470 $self->send_packet ($self->{query_queue}[0][0])
1915 if @{ $self->{query_queue} } == 1; 2471 if @{ $self->{query_queue} } == 1;
2472
2473 1
1916} 2474}
1917 2475
1918cf::client->attach ( 2476cf::client->attach (
2477 on_connect => sub {
2478 my ($ns) = @_;
2479
2480 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2481 },
1919 on_reply => sub { 2482 on_reply => sub {
1920 my ($ns, $msg) = @_; 2483 my ($ns, $msg) = @_;
1921 2484
1922 # this weird shuffling is so that direct followup queries 2485 # this weird shuffling is so that direct followup queries
1923 # get handled first 2486 # get handled first
1924 my $queue = delete $ns->{query_queue} 2487 my $queue = delete $ns->{query_queue}
1925 or return; # be conservative, not sure how that can happen, but we saw a crash here 2488 or return; # be conservative, not sure how that can happen, but we saw a crash here
1926 2489
1927 (shift @$queue)->[1]->($msg); 2490 (shift @$queue)->[1]->($msg);
2491 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1928 2492
1929 push @{ $ns->{query_queue} }, @$queue; 2493 push @{ $ns->{query_queue} }, @$queue;
1930 2494
1931 if (@{ $ns->{query_queue} } == @$queue) { 2495 if (@{ $ns->{query_queue} } == @$queue) {
1932 if (@$queue) { 2496 if (@$queue) {
… …
1934 } else { 2498 } else {
1935 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2499 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1936 } 2500 }
1937 } 2501 }
1938 }, 2502 },
2503 on_exticmd => sub {
2504 my ($ns, $buf) = @_;
2505
2506 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2507
2508 if (ref $msg) {
2509 if (my $cb = $EXTICMD{$msg->{msgtype}}) {
2510 if (my %reply = $cb->($ns, $msg)) {
2511 $reply{msgid} = $msg->{msgid};
2512 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2513 }
2514 }
2515 } else {
2516 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2517 }
2518
2519 cf::override;
2520 },
1939); 2521);
1940 2522
1941=item $client->async (\&cb) 2523=item $client->async (\&cb)
1942 2524
1943Create a new coroutine, running the specified callback. The coroutine will 2525Create a new coroutine, running the specified callback. The coroutine will
… …
1990 2572
1991# here we export the classes and methods available to script code 2573# here we export the classes and methods available to script code
1992 2574
1993=pod 2575=pod
1994 2576
1995The following fucntions and emthods are available within a safe environment: 2577The following functions and methods are available within a safe environment:
1996 2578
1997 cf::object contr pay_amount pay_player map 2579 cf::object contr pay_amount pay_player map
1998 cf::object::player player 2580 cf::object::player player
1999 cf::player peaceful 2581 cf::player peaceful
2000 cf::map trigger 2582 cf::map trigger
… …
2081=back 2663=back
2082 2664
2083=cut 2665=cut
2084 2666
2085############################################################################# 2667#############################################################################
2668# the server's init and main functions
2086 2669
2087=head2 EXTENSION DATABASE SUPPORT 2670sub load_facedata($) {
2671 my ($path) = @_;
2088 2672
2089Crossfire maintains a very simple database for extension use. It can 2673 warn "loading facedata from $path\n";
2090currently store anything that can be serialised using Storable, which
2091excludes objects.
2092 2674
2093The parameter C<$family> should best start with the name of the extension 2675 my $facedata;
2094using it, it should be unique. 2676 0 < aio_load $path, $facedata
2677 or die "$path: $!";
2095 2678
2096=over 4 2679 $facedata = Coro::Storable::thaw $facedata;
2097 2680
2098=item $hashref = cf::db_get $family 2681 $facedata->{version} == 2
2682 or cf::cleanup "$path: version mismatch, cannot proceed.";
2099 2683
2100Return a hashref for use by the extension C<$family>, which can be
2101modified. After modifications, you have to call C<cf::db_dirty> or
2102C<cf::db_sync>.
2103
2104=item $value = cf::db_get $family => $key
2105
2106Returns a single value from the database
2107
2108=item cf::db_put $family => $hashref
2109
2110Stores the given family hashref into the database. Updates are delayed, if
2111you want the data to be synced to disk immediately, use C<cf::db_sync>.
2112
2113=item cf::db_put $family => $key => $value
2114
2115Stores the given C<$value> in the family hash. Updates are delayed, if you
2116want the data to be synced to disk immediately, use C<cf::db_sync>.
2117
2118=item cf::db_dirty
2119
2120Marks the database as dirty, to be updated at a later time.
2121
2122=item cf::db_sync
2123
2124Immediately write the database to disk I<if it is dirty>.
2125
2126=cut
2127
2128our $DB;
2129
2130{
2131 my $path = cf::localdir . "/database.pst";
2132
2133 sub db_load() {
2134 $DB = stat $path ? Storable::retrieve $path : { };
2135 } 2684 {
2685 my $faces = $facedata->{faceinfo};
2136 2686
2137 my $pid; 2687 while (my ($face, $info) = each %$faces) {
2138 2688 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2139 sub db_save() { 2689 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2140 waitpid $pid, 0 if $pid; 2690 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2141 if (0 == ($pid = fork)) { 2691 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2142 $DB->{_meta}{version} = 1; 2692 Coro::cede;
2143 Storable::nstore $DB, "$path~";
2144 rename "$path~", $path;
2145 cf::_exit 0 if defined $pid;
2146 }
2147 }
2148
2149 my $dirty;
2150
2151 sub db_sync() {
2152 db_save if $dirty;
2153 undef $dirty;
2154 }
2155
2156 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
2157 db_sync;
2158 });
2159
2160 sub db_dirty() {
2161 $dirty = 1;
2162 $idle->start;
2163 }
2164
2165 sub db_get($;$) {
2166 @_ >= 2
2167 ? $DB->{$_[0]}{$_[1]}
2168 : ($DB->{$_[0]} ||= { })
2169 }
2170
2171 sub db_put($$;$) {
2172 if (@_ >= 3) {
2173 $DB->{$_[0]}{$_[1]} = $_[2];
2174 } else {
2175 $DB->{$_[0]} = $_[1];
2176 }
2177 db_dirty;
2178 }
2179
2180 cf::global->attach (
2181 prio => 10000,
2182 on_cleanup => sub {
2183 db_sync;
2184 }, 2693 }
2185 );
2186}
2187 2694
2188############################################################################# 2695 while (my ($face, $info) = each %$faces) {
2189# the server's main() 2696 next unless $info->{smooth};
2697 my $idx = cf::face::find $face
2698 or next;
2699 if (my $smooth = cf::face::find $info->{smooth}) {
2700 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2701 } else {
2702 warn "smooth face '$info->{smooth}' not found for face '$face'";
2703 }
2704 Coro::cede;
2705 }
2706 }
2707
2708 {
2709 my $anims = $facedata->{animinfo};
2710
2711 while (my ($anim, $info) = each %$anims) {
2712 cf::anim::set $anim, $info->{frames}, $info->{facings};
2713 Coro::cede;
2714 }
2715
2716 cf::anim::invalidate_all; # d'oh
2717 }
2718
2719 1
2720}
2721
2722sub reload_regions {
2723 load_resource_file "$MAPDIR/regions"
2724 or die "unable to load regions file\n";
2725}
2726
2727sub reload_facedata {
2728 load_facedata "$DATADIR/facedata"
2729 or die "unable to load facedata\n";
2730}
2731
2732sub reload_archetypes {
2733 load_resource_file "$DATADIR/archetypes"
2734 or die "unable to load archetypes\n";
2735 #d# NEED to laod twice to resolve forward references
2736 # this really needs to be done in an extra post-pass
2737 # (which needs to be synchronous, so solve it differently)
2738 load_resource_file "$DATADIR/archetypes"
2739 or die "unable to load archetypes\n";
2740}
2741
2742sub reload_treasures {
2743 load_resource_file "$DATADIR/treasures"
2744 or die "unable to load treasurelists\n";
2745}
2746
2747sub reload_resources {
2748 warn "reloading resource files...\n";
2749
2750 reload_regions;
2751 reload_facedata;
2752 #reload_archetypes;#d#
2753 reload_archetypes;
2754 reload_treasures;
2755
2756 warn "finished reloading resource files\n";
2757}
2758
2759sub init {
2760 reload_resources;
2761}
2190 2762
2191sub cfg_load { 2763sub cfg_load {
2192 open my $fh, "<:utf8", cf::confdir . "/config" 2764 open my $fh, "<:utf8", "$CONFDIR/config"
2193 or return; 2765 or return;
2194 2766
2195 local $/; 2767 local $/;
2196 *CFG = YAML::Syck::Load <$fh>; 2768 *CFG = YAML::Syck::Load <$fh>;
2197 2769
… …
2211 2783
2212sub main { 2784sub main {
2213 # we must not ever block the main coroutine 2785 # we must not ever block the main coroutine
2214 local $Coro::idle = sub { 2786 local $Coro::idle = sub {
2215 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 2787 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2788 (async {
2216 async { Event::one_event }; 2789 Event::one_event;
2790 })->prio (Coro::PRIO_MAX);
2217 }; 2791 };
2218 2792
2219 cfg_load; 2793 cfg_load;
2220 db_load; 2794 db_init;
2221 load_extensions; 2795 load_extensions;
2796
2797 $TICK_WATCHER->start;
2222 Event::loop; 2798 Event::loop;
2223} 2799}
2224 2800
2225############################################################################# 2801#############################################################################
2226# initialisation and cleanup 2802# initialisation and cleanup
2227 2803
2228# install some emergency cleanup handlers 2804# install some emergency cleanup handlers
2229BEGIN { 2805BEGIN {
2230 for my $signal (qw(INT HUP TERM)) { 2806 for my $signal (qw(INT HUP TERM)) {
2231 Event->signal ( 2807 Event->signal (
2808 reentrant => 0,
2232 data => WF_AUTOCANCEL, 2809 data => WF_AUTOCANCEL,
2233 signal => $signal, 2810 signal => $signal,
2811 prio => 0,
2234 cb => sub { 2812 cb => sub {
2235 cf::cleanup "SIG$signal"; 2813 cf::cleanup "SIG$signal";
2236 }, 2814 },
2237 ); 2815 );
2238 } 2816 }
2817}
2818
2819sub write_runtime {
2820 my $runtime = "$LOCALDIR/runtime";
2821
2822 # first touch the runtime file to show we are still running:
2823 # the fsync below can take a very very long time.
2824
2825 IO::AIO::aio_utime $runtime, undef, undef;
2826
2827 my $guard = cf::lock_acquire "write_runtime";
2828
2829 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2830 or return;
2831
2832 my $value = $cf::RUNTIME + 90 + 10;
2833 # 10 is the runtime save interval, for a monotonic clock
2834 # 60 allows for the watchdog to kill the server.
2835
2836 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2837 and return;
2838
2839 # always fsync - this file is important
2840 aio_fsync $fh
2841 and return;
2842
2843 # touch it again to show we are up-to-date
2844 aio_utime $fh, undef, undef;
2845
2846 close $fh
2847 or return;
2848
2849 aio_rename "$runtime~", $runtime
2850 and return;
2851
2852 warn "runtime file written.\n";
2853
2854 1
2239} 2855}
2240 2856
2241sub emergency_save() { 2857sub emergency_save() {
2242 my $freeze_guard = cf::freeze_mainloop; 2858 my $freeze_guard = cf::freeze_mainloop;
2243 2859
… …
2260 my $map = $cf::MAP{$path} or next; 2876 my $map = $cf::MAP{$path} or next;
2261 $map->valid or next; 2877 $map->valid or next;
2262 $map->save; 2878 $map->save;
2263 } 2879 }
2264 warn "end emergency map save\n"; 2880 warn "end emergency map save\n";
2881
2882 warn "begin emergency database checkpoint\n";
2883 BDB::db_env_txn_checkpoint $DB_ENV;
2884 warn "end emergency database checkpoint\n";
2265 }; 2885 };
2266 2886
2267 warn "leave emergency perl save\n"; 2887 warn "leave emergency perl save\n";
2268} 2888}
2269 2889
2890sub post_cleanup {
2891 my ($make_core) = @_;
2892
2893 warn Carp::longmess "post_cleanup backtrace"
2894 if $make_core;
2895}
2896
2270sub reload() { 2897sub do_reload_perl() {
2271 # can/must only be called in main 2898 # can/must only be called in main
2272 if ($Coro::current != $Coro::main) { 2899 if ($Coro::current != $Coro::main) {
2273 warn "can only reload from main coroutine\n"; 2900 warn "can only reload from main coroutine";
2274 return; 2901 return;
2275 } 2902 }
2276 2903
2277 warn "reloading..."; 2904 warn "reloading...";
2278 2905
2279 warn "freezing server"; 2906 warn "entering sync_job";
2280 my $guard = freeze_mainloop; 2907
2908 cf::sync_job {
2909 cf::write_runtime; # external watchdog should not bark
2281 cf::emergency_save; 2910 cf::emergency_save;
2911 cf::write_runtime; # external watchdog should not bark
2282 2912
2283 warn "sync database to disk"; 2913 warn "syncing database to disk";
2284 cf::db_sync; 2914 BDB::db_env_txn_checkpoint $DB_ENV;
2285 IO::AIO::flush;
2286 2915
2287 eval {
2288 # if anything goes wrong in here, we should simply crash as we already saved 2916 # if anything goes wrong in here, we should simply crash as we already saved
2289 2917
2290 warn "cancel all watchers"; 2918 warn "cancelling all WF_AUTOCANCEL watchers";
2291 for (Event::all_watchers) { 2919 for (Event::all_watchers) {
2292 $_->cancel if $_->data & WF_AUTOCANCEL; 2920 $_->cancel if $_->data & WF_AUTOCANCEL;
2293 } 2921 }
2294 2922
2923 warn "flushing outstanding aio requests";
2924 for (;;) {
2925 BDB::flush;
2926 IO::AIO::flush;
2927 Coro::cede;
2928 last unless IO::AIO::nreqs || BDB::nreqs;
2929 warn "iterate...";
2930 }
2931
2932 ++$RELOAD;
2933
2295 warn "cancel all extension coros"; 2934 warn "cancelling all extension coros";
2296 $_->cancel for values %EXT_CORO; 2935 $_->cancel for values %EXT_CORO;
2297 %EXT_CORO = (); 2936 %EXT_CORO = ();
2298 2937
2299 warn "remove commands"; 2938 warn "removing commands";
2300 %COMMAND = (); 2939 %COMMAND = ();
2301 2940
2302 warn "remove ext commands"; 2941 warn "removing ext/exti commands";
2303 %EXTCMD = (); 2942 %EXTCMD = ();
2943 %EXTICMD = ();
2304 2944
2305 warn "unload/nuke all extensions"; 2945 warn "unloading/nuking all extensions";
2306 for my $pkg (@EXTS) { 2946 for my $pkg (@EXTS) {
2307 warn "... unloading $pkg"; 2947 warn "... unloading $pkg";
2308 2948
2309 if (my $cb = $pkg->can ("unload")) { 2949 if (my $cb = $pkg->can ("unload")) {
2310 eval { 2950 eval {
… …
2315 2955
2316 warn "... nuking $pkg"; 2956 warn "... nuking $pkg";
2317 Symbol::delete_package $pkg; 2957 Symbol::delete_package $pkg;
2318 } 2958 }
2319 2959
2320 warn "unload all perl modules loaded from $LIBDIR"; 2960 warn "unloading all perl modules loaded from $LIBDIR";
2321 while (my ($k, $v) = each %INC) { 2961 while (my ($k, $v) = each %INC) {
2322 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2962 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2323 2963
2324 warn "removing <$k>"; 2964 warn "... unloading $k";
2325 delete $INC{$k}; 2965 delete $INC{$k};
2326 2966
2327 $k =~ s/\.pm$//; 2967 $k =~ s/\.pm$//;
2328 $k =~ s/\//::/g; 2968 $k =~ s/\//::/g;
2329 2969
… …
2332 } 2972 }
2333 2973
2334 Symbol::delete_package $k; 2974 Symbol::delete_package $k;
2335 } 2975 }
2336 2976
2337 warn "get rid of safe::, as good as possible"; 2977 warn "getting rid of safe::, as good as possible";
2338 Symbol::delete_package "safe::$_" 2978 Symbol::delete_package "safe::$_"
2339 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2979 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2340 2980
2341 warn "unload cf.pm \"a bit\""; 2981 warn "unloading cf.pm \"a bit\"";
2342 delete $INC{"cf.pm"}; 2982 delete $INC{"cf.pm"};
2983 delete $INC{"cf/pod.pm"};
2343 2984
2344 # don't, removes xs symbols, too, 2985 # don't, removes xs symbols, too,
2345 # and global variables created in xs 2986 # and global variables created in xs
2346 #Symbol::delete_package __PACKAGE__; 2987 #Symbol::delete_package __PACKAGE__;
2347 2988
2989 warn "unload completed, starting to reload now";
2990
2348 warn "reloading cf.pm"; 2991 warn "reloading cf.pm";
2349 require cf; 2992 require cf;
2350 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2993 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2351 2994
2352 warn "load config and database again"; 2995 warn "loading config and database again";
2353 cf::cfg_load; 2996 cf::cfg_load;
2354 cf::db_load;
2355 2997
2356 warn "load extensions"; 2998 warn "loading extensions";
2357 cf::load_extensions; 2999 cf::load_extensions;
2358 3000
2359 warn "reattach attachments to objects/players"; 3001 warn "reattaching attachments to objects/players";
2360 _global_reattach; 3002 _global_reattach; # objects, sockets
2361 warn "reattach attachments to maps"; 3003 warn "reattaching attachments to maps";
2362 reattach $_ for values %MAP; 3004 reattach $_ for values %MAP;
2363 }; 3005 warn "reattaching attachments to players";
3006 reattach $_ for values %PLAYER;
2364 3007
2365 if ($@) { 3008 warn "leaving sync_job";
3009
3010 1
3011 } or do {
2366 warn $@; 3012 warn $@;
2367 warn "error while reloading, exiting."; 3013 warn "error while reloading, exiting.";
2368 exit 1; 3014 exit 1;
2369 } 3015 };
2370 3016
2371 warn "reloaded"; 3017 warn "reloaded";
2372}; 3018};
2373 3019
3020our $RELOAD_WATCHER; # used only during reload
3021
3022sub reload_perl() {
3023 # doing reload synchronously and two reloads happen back-to-back,
3024 # coro crashes during coro_state_free->destroy here.
3025
3026 $RELOAD_WATCHER ||= Event->timer (
3027 reentrant => 0,
3028 after => 0,
3029 data => WF_AUTOCANCEL,
3030 cb => sub {
3031 do_reload_perl;
3032 undef $RELOAD_WATCHER;
3033 },
3034 );
3035}
3036
2374register_command "reload" => sub { 3037register_command "reload" => sub {
2375 my ($who, $arg) = @_; 3038 my ($who, $arg) = @_;
2376 3039
2377 if ($who->flag (FLAG_WIZ)) { 3040 if ($who->flag (FLAG_WIZ)) {
2378 $who->message ("start of reload.");
2379 reload;
2380 $who->message ("end of reload."); 3041 $who->message ("reloading server.");
3042 async { reload_perl };
2381 } 3043 }
2382}; 3044};
2383 3045
2384unshift @INC, $LIBDIR; 3046unshift @INC, $LIBDIR;
2385 3047
3048my $bug_warning = 0;
3049
3050our @WAIT_FOR_TICK;
3051our @WAIT_FOR_TICK_BEGIN;
3052
3053sub wait_for_tick {
3054 return unless $TICK_WATCHER->is_active;
3055 return if $Coro::current == $Coro::main;
3056
3057 my $signal = new Coro::Signal;
3058 push @WAIT_FOR_TICK, $signal;
3059 $signal->wait;
3060}
3061
3062sub wait_for_tick_begin {
3063 return unless $TICK_WATCHER->is_active;
3064 return if $Coro::current == $Coro::main;
3065
3066 my $signal = new Coro::Signal;
3067 push @WAIT_FOR_TICK_BEGIN, $signal;
3068 $signal->wait;
3069}
3070
3071 my $min = 1e6;#d#
3072 my $avg = 10;
2386$TICK_WATCHER = Event->timer ( 3073$TICK_WATCHER = Event->timer (
2387 reentrant => 0, 3074 reentrant => 0,
3075 parked => 1,
2388 prio => 0, 3076 prio => 0,
2389 at => $NEXT_TICK || $TICK, 3077 at => $NEXT_TICK || $TICK,
2390 data => WF_AUTOCANCEL, 3078 data => WF_AUTOCANCEL,
2391 cb => sub { 3079 cb => sub {
3080 if ($Coro::current != $Coro::main) {
3081 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3082 unless ++$bug_warning > 10;
3083 return;
3084 }
3085
2392 $NOW = Event::time; 3086 $NOW = $tick_start = Event::time;
2393 3087
2394 cf::server_tick; # one server iteration 3088 cf::server_tick; # one server iteration
3089
3090 0 && sync_job {#d#
3091 for(1..10) {
3092 my $t = Event::time;
3093 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3094 or die;
3095
3096 $map->width (50);
3097 $map->height (50);
3098 $map->alloc;
3099 $map->_load_objects ("/tmp/x.map", 1);
3100 my $t = Event::time - $t;
3101
3102 #next unless $t < 0.0013;#d#
3103 if ($t < $min) {
3104 $min = $t;
3105 }
3106 $avg = $avg * 0.99 + $t * 0.01;
3107 }
3108 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3109 exit 0;
3110 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3111 };
3112
2395 $RUNTIME += $TICK; 3113 $RUNTIME += $TICK;
2396 $NEXT_TICK += $TICK; 3114 $NEXT_TICK += $TICK;
2397 3115
2398 $WAIT_FOR_TICK->broadcast; 3116 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2399 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited; 3117 $NEXT_RUNTIME_WRITE = $NOW + 10;
3118 Coro::async_pool {
3119 write_runtime
3120 or warn "ERROR: unable to write runtime file: $!";
3121 };
3122 }
3123
3124# my $AFTER = Event::time;
3125# warn $AFTER - $NOW;#d#
3126
3127 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3128 $sig->send;
3129 }
3130 while (my $sig = shift @WAIT_FOR_TICK) {
3131 $sig->send;
3132 }
3133
3134 $NOW = Event::time;
2400 3135
2401 # if we are delayed by four ticks or more, skip them all 3136 # if we are delayed by four ticks or more, skip them all
2402 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3137 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2403 3138
2404 $TICK_WATCHER->at ($NEXT_TICK); 3139 $TICK_WATCHER->at ($NEXT_TICK);
2405 $TICK_WATCHER->start; 3140 $TICK_WATCHER->start;
3141
3142 $LOAD = ($NOW - $tick_start) / $TICK;
3143 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3144
3145 _post_tick;
3146
3147
2406 }, 3148 },
2407); 3149);
2408 3150
3151{
3152 BDB::max_poll_time $TICK * 0.1;
3153 $BDB_POLL_WATCHER = Event->io (
3154 reentrant => 0,
3155 fd => BDB::poll_fileno,
3156 poll => 'r',
3157 prio => 0,
3158 data => WF_AUTOCANCEL,
3159 cb => \&BDB::poll_cb,
3160 );
3161 BDB::min_parallel 8;
3162
3163 BDB::set_sync_prepare {
3164 my $status;
3165 my $current = $Coro::current;
3166 (
3167 sub {
3168 $status = $!;
3169 $current->ready; undef $current;
3170 },
3171 sub {
3172 Coro::schedule while defined $current;
3173 $! = $status;
3174 },
3175 )
3176 };
3177
3178 unless ($DB_ENV) {
3179 $DB_ENV = BDB::db_env_create;
3180
3181 cf::sync_job {
3182 eval {
3183 BDB::db_env_open
3184 $DB_ENV,
3185 $BDBDIR,
3186 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3187 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3188 0666;
3189
3190 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3191
3192 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3193 $DB_ENV->set_lk_detect;
3194 };
3195
3196 cf::cleanup "db_env_open(db): $@" if $@;
3197 };
3198 }
3199}
3200
3201{
3202 IO::AIO::min_parallel 8;
3203
3204 undef $Coro::AIO::WATCHER;
2409IO::AIO::max_poll_time $TICK * 0.2; 3205 IO::AIO::max_poll_time $TICK * 0.1;
2410
2411$AIO_POLL_WATCHER = Event->io ( 3206 $AIO_POLL_WATCHER = Event->io (
2412 fd => IO::AIO::poll_fileno, 3207 reentrant => 0,
2413 poll => 'r',
2414 prio => 5,
2415 data => WF_AUTOCANCEL,
2416 cb => \&IO::AIO::poll_cb,
2417);
2418
2419$WRITE_RUNTIME_WATCHER = Event->timer (
2420 data => WF_AUTOCANCEL, 3208 data => WF_AUTOCANCEL,
2421 after => 0, 3209 fd => IO::AIO::poll_fileno,
2422 interval => 10, 3210 poll => 'r',
2423 cb => sub { 3211 prio => 6,
2424 (Coro::unblock_sub { 3212 cb => \&IO::AIO::poll_cb,
2425 write_runtime 3213 );
2426 or warn "ERROR: unable to write runtime file: $!"; 3214}
3215
3216my $_log_backtrace;
3217
3218sub _log_backtrace {
3219 my ($msg, @addr) = @_;
3220
3221 $msg =~ s/\n//;
3222
3223 # limit the # of concurrent backtraces
3224 if ($_log_backtrace < 2) {
3225 ++$_log_backtrace;
3226 async {
3227 my @bt = fork_call {
3228 @addr = map { sprintf "%x", $_ } @addr;
3229 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3230 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3231 or die "addr2line: $!";
3232
3233 my @funcs;
3234 my @res = <$fh>;
3235 chomp for @res;
3236 while (@res) {
3237 my ($func, $line) = splice @res, 0, 2, ();
3238 push @funcs, "[$func] $line";
3239 }
3240
3241 @funcs
3242 };
3243
3244 LOG llevInfo, "[ABT] $msg\n";
3245 LOG llevInfo, "[ABT] $_\n" for @bt;
3246 --$_log_backtrace;
2427 })->(); 3247 };
3248 } else {
3249 LOG llevInfo, "[ABT] $msg\n";
3250 LOG llevInfo, "[ABT] [suppressed]\n";
2428 }, 3251 }
2429); 3252}
3253
3254# load additional modules
3255use cf::pod;
2430 3256
2431END { cf::emergency_save } 3257END { cf::emergency_save }
2432 3258
24331 32591
2434 3260

Diff Legend

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