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

Diff Legend

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