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

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

Diff Legend

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