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.168 by root, Sun Jan 14 00:37:14 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) = @_;
938
939 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
688 940
689 my $registry = $obj->registry; 941 my $registry = $obj->registry;
690 942
691 @$registry = (); 943 @$registry = ();
692 944
… …
739 $filename, length $$rdata, scalar @$objs; 991 $filename, length $$rdata, scalar @$objs;
740 992
741 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 993 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
742 chmod SAVE_MODE, $fh; 994 chmod SAVE_MODE, $fh;
743 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 995 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
744 aio_fsync $fh; 996 aio_fsync $fh if $cf::USE_FSYNC;
745 close $fh; 997 close $fh;
746 998
747 if (@$objs) { 999 if (@$objs) {
748 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) {
749 chmod SAVE_MODE, $fh; 1001 chmod SAVE_MODE, $fh;
750 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1002 my $data = Storable::nfreeze { version => 1, objs => $objs };
751 aio_write $fh, 0, (length $data), $data, 0; 1003 aio_write $fh, 0, (length $data), $data, 0;
752 aio_fsync $fh; 1004 aio_fsync $fh if $cf::USE_FSYNC;
753 close $fh; 1005 close $fh;
754 aio_rename "$filename.pst~", "$filename.pst"; 1006 aio_rename "$filename.pst~", "$filename.pst";
755 } 1007 }
756 } else { 1008 } else {
757 aio_unlink "$filename.pst"; 1009 aio_unlink "$filename.pst";
… …
789 or return; 1041 or return;
790 $av = eval { (Storable::thaw $av)->{objs} }; 1042 $av = eval { (Storable::thaw $av)->{objs} };
791 } 1043 }
792 1044
793 warn sprintf "loading %s (%d)\n", 1045 warn sprintf "loading %s (%d)\n",
794 $filename, length $data, scalar @{$av || []};#d# 1046 $filename, length $data, scalar @{$av || []};
795 return ($data, $av); 1047 return ($data, $av);
796} 1048}
1049
1050=head2 COMMAND CALLBACKS
1051
1052=over 4
1053
1054=cut
797 1055
798############################################################################# 1056#############################################################################
799# command handling &c 1057# command handling &c
800 1058
801=item cf::register_command $name => \&callback($ob,$args); 1059=item cf::register_command $name => \&callback($ob,$args);
… …
814 push @{ $COMMAND{$name} }, [$caller, $cb]; 1072 push @{ $COMMAND{$name} }, [$caller, $cb];
815} 1073}
816 1074
817=item cf::register_extcmd $name => \&callback($pl,$packet); 1075=item cf::register_extcmd $name => \&callback($pl,$packet);
818 1076
819Register 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.
820 1082
821If 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
822called. 1084called.
823 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
824=cut 1097=cut
825 1098
826sub register_extcmd { 1099sub register_extcmd {
827 my ($name, $cb) = @_; 1100 my ($name, $cb) = @_;
828 1101
829 $EXTCMD{$name} = $cb; 1102 $EXTCMD{$name} = $cb;
1103}
1104
1105sub register_exticmd {
1106 my ($name, $cb) = @_;
1107
1108 $EXTICMD{$name} = $cb;
830} 1109}
831 1110
832cf::player->attach ( 1111cf::player->attach (
833 on_command => sub { 1112 on_command => sub {
834 my ($pl, $name, $params) = @_; 1113 my ($pl, $name, $params) = @_;
… …
843 cf::override; 1122 cf::override;
844 }, 1123 },
845 on_extcmd => sub { 1124 on_extcmd => sub {
846 my ($pl, $buf) = @_; 1125 my ($pl, $buf) = @_;
847 1126
848 my $msg = eval { from_json $buf }; 1127 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
849 1128
850 if (ref $msg) { 1129 if (ref $msg) {
851 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1130 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
852 if (my %reply = $cb->($pl, $msg)) { 1131 if (my %reply = $cb->($pl, $msg)) {
853 $pl->ext_reply ($msg->{msgid}, %reply); 1132 $pl->ext_reply ($msg->{msgid}, %reply);
… …
859 1138
860 cf::override; 1139 cf::override;
861 }, 1140 },
862); 1141);
863 1142
864sub load_extension {
865 my ($path) = @_;
866
867 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
868 my $base = $1;
869 my $pkg = $1;
870 $pkg =~ s/[^[:word:]]/_/g;
871 $pkg = "ext::$pkg";
872
873 warn "... loading '$path' into '$pkg'\n";
874
875 open my $fh, "<:utf8", $path
876 or die "$path: $!";
877
878 my $source =
879 "package $pkg; use strict; use utf8;\n"
880 . "#line 1 \"$path\"\n{\n"
881 . (do { local $/; <$fh> })
882 . "\n};\n1";
883
884 unless (eval $source) {
885 my $msg = $@ ? "$path: $@\n"
886 : "extension disabled.\n";
887 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
888 warn $@;
889 warn "mandatory extension failed to load, exiting.\n";
890 exit 1;
891 }
892 die $@;
893 }
894
895 push @EXTS, $pkg;
896}
897
898sub load_extensions { 1143sub load_extensions {
1144 cf::sync_job {
1145 my %todo;
1146
899 for my $ext (<$LIBDIR/*.ext>) { 1147 for my $path (<$LIBDIR/*.ext>) {
900 next unless -r $ext; 1148 next unless -r $path;
901 eval { 1149
902 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;
903 1 1207 }
904 } or warn "$ext not loaded: $@"; 1208
1209 skip:
1210 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1211 unless $progress;
1212 }
905 } 1213 };
906} 1214}
907 1215
908############################################################################# 1216#############################################################################
909 1217
1218=back
1219
910=head2 CORE EXTENSIONS 1220=head2 CORE EXTENSIONS
911 1221
912Functions and methods that extend core crossfire objects. 1222Functions and methods that extend core crossfire objects.
913 1223
914=cut 1224=cut
… …
926Returns the given player object, loading it if necessary (might block). 1236Returns the given player object, loading it if necessary (might block).
927 1237
928=cut 1238=cut
929 1239
930sub playerdir($) { 1240sub playerdir($) {
931 cf::localdir 1241 "$PLAYERDIR/"
932 . "/"
933 . cf::playerdir
934 . "/"
935 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1242 . (ref $_[0] ? $_[0]->ob->name : $_[0])
936} 1243}
937 1244
938sub path($) { 1245sub path($) {
939 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1246 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
940 1247
941 (playerdir $login) . "/$login.pl" 1248 (playerdir $login) . "/playerdata"
942} 1249}
943 1250
944sub find_active($) { 1251sub find_active($) {
945 $cf::PLAYER{$_[0]} 1252 $cf::PLAYER{$_[0]}
946 and $cf::PLAYER{$_[0]}->active 1253 and $cf::PLAYER{$_[0]}->active
… …
949 1256
950sub exists($) { 1257sub exists($) {
951 my ($login) = @_; 1258 my ($login) = @_;
952 1259
953 $cf::PLAYER{$login} 1260 $cf::PLAYER{$login}
954 or cf::sync_job { !aio_stat $login } 1261 or cf::sync_job { !aio_stat path $login }
955} 1262}
956 1263
957sub find($) { 1264sub find($) {
958 return $cf::PLAYER{$_[0]} || do { 1265 return $cf::PLAYER{$_[0]} || do {
959 my $login = $_[0]; 1266 my $login = $_[0];
960 1267
961 my $guard = cf::lock_acquire "user_find:$login"; 1268 my $guard = cf::lock_acquire "user_find:$login";
962 1269
963 $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
964 my $pl = load_pl path $login 1278 my $pl = load_pl path $login
965 or return; 1279 or return;
966 $cf::PLAYER{$login} = $pl 1280 $cf::PLAYER{$login} = $pl
967 } 1281 }
968 } 1282 }
… …
1005 1319
1006=cut 1320=cut
1007 1321
1008sub quit_character { 1322sub quit_character {
1009 my ($pl) = @_; 1323 my ($pl) = @_;
1324
1325 my $name = $pl->ob->name;
1010 1326
1011 $pl->{deny_save} = 1; 1327 $pl->{deny_save} = 1;
1012 $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
1013 1329
1014 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1330 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
… …
1019 my $path = playerdir $pl; 1335 my $path = playerdir $pl;
1020 my $temp = "$path~$cf::RUNTIME~deleting~"; 1336 my $temp = "$path~$cf::RUNTIME~deleting~";
1021 aio_rename $path, $temp; 1337 aio_rename $path, $temp;
1022 delete $cf::PLAYER{$pl->ob->name}; 1338 delete $cf::PLAYER{$pl->ob->name};
1023 $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
1024 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;
1025} 1361}
1026 1362
1027=item cf::player::list_logins 1363=item cf::player::list_logins
1028 1364
1029Returns 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
1030while and may block, so not sync_job-capable, ever. 1366while and may block, so not sync_job-capable, ever.
1031 1367
1032=cut 1368=cut
1033 1369
1034sub list_logins { 1370sub list_logins {
1035 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1371 my $dirs = aio_readdir $PLAYERDIR
1036 or return []; 1372 or return [];
1037 1373
1038 my @logins; 1374 my @logins;
1039 1375
1040 for my $login (@$dirs) { 1376 for my $login (@$dirs) {
… …
1057=cut 1393=cut
1058 1394
1059sub maps($) { 1395sub maps($) {
1060 my ($pl) = @_; 1396 my ($pl) = @_;
1061 1397
1398 $pl = ref $pl ? $pl->ob->name : $pl;
1399
1062 my $files = aio_readdir playerdir $pl 1400 my $files = aio_readdir playerdir $pl
1063 or return; 1401 or return;
1064 1402
1065 my @paths; 1403 my @paths;
1066 1404
1067 for (@$files) { 1405 for (@$files) {
1068 utf8::decode $_; 1406 utf8::decode $_;
1069 next if /\.(?:pl|pst)$/; 1407 next if /\.(?:pl|pst)$/;
1070 next unless /^$PATH_SEP/o; 1408 next unless /^$PATH_SEP/o;
1071 1409
1072 s/\.map$//; 1410 push @paths, cf::map::normalise "~$pl/$_";
1073 push @paths, "~" . $pl->ob->name . "/" . $_;
1074 } 1411 }
1075 1412
1076 \@paths 1413 \@paths
1077} 1414}
1078 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
1079=item $player->ext_reply ($msgid, $msgtype, %msg) 1466=item $player->ext_reply ($msgid, %msg)
1080 1467
1081Sends an ext reply to the player. 1468Sends an ext reply to the player.
1082 1469
1083=cut 1470=cut
1084 1471
1085sub ext_reply($$$%) { 1472sub ext_reply($$%) {
1086 my ($self, $id, %msg) = @_; 1473 my ($self, $id, %msg) = @_;
1087 1474
1088 $msg{msgid} = $id; 1475 $msg{msgid} = $id;
1089 1476 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1090 $self->send ("ext " . cf::to_json \%msg);
1091} 1477}
1092 1478
1093package 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}
1094 1519
1095=back 1520=back
1096
1097 1521
1098=head3 cf::map 1522=head3 cf::map
1099 1523
1100=over 4 1524=over 4
1101 1525
… …
1105 1529
1106use Fcntl; 1530use Fcntl;
1107use Coro::AIO; 1531use Coro::AIO;
1108 1532
1109use overload 1533use overload
1110 '""' => \&as_string; 1534 '""' => \&as_string,
1535 fallback => 1;
1111 1536
1112our $MAX_RESET = 3600; 1537our $MAX_RESET = 3600;
1113our $DEFAULT_RESET = 3000; 1538our $DEFAULT_RESET = 3000;
1114 1539
1115sub generate_random_map { 1540sub generate_random_map {
1116 my ($self, $rmp) = @_; 1541 my ($self, $rmp) = @_;
1117
1118 # mit "rum" bekleckern, nicht 1542 # mit "rum" bekleckern, nicht
1119 $self->_create_random_map ( 1543 $self->_create_random_map (
1120 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1544 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1121 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1545 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1122 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1546 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1129 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1553 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1130 (cf::region::find $rmp->{region}), $rmp->{custom} 1554 (cf::region::find $rmp->{region}), $rmp->{custom}
1131 ) 1555 )
1132} 1556}
1133 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
1134sub register { 1566sub register {
1135 my (undef, $regex) = @_; 1567 my (undef, $regex, $prio) = @_;
1136 my $pkg = caller; 1568 my $pkg = caller;
1137 1569
1138 no strict; 1570 no strict;
1139 push @{"$pkg\::ISA"}, __PACKAGE__; 1571 push @{"$pkg\::ISA"}, __PACKAGE__;
1140 1572
1141 $EXT_MAP{$pkg} = qr<$regex>; 1573 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1142} 1574}
1143 1575
1144# also paths starting with '/' 1576# also paths starting with '/'
1145$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}
1146 1588
1147sub normalise { 1589sub normalise {
1148 my ($path, $base) = @_; 1590 my ($path, $base) = @_;
1591
1592 $path = "$path"; # make sure its a string
1593
1594 $path =~ s/\.map$//;
1149 1595
1150 # map plan: 1596 # map plan:
1151 # 1597 #
1152 # /! non-realised random map exit (special hack!) 1598 # /! non-realised random map exit (special hack!)
1153 # {... are special paths that are not being touched 1599 # {... are special paths that are not being touched
… …
1181 1627
1182 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
1183 1629
1184 $path = normalise $path, $base; 1630 $path = normalise $path, $base;
1185 1631
1186 for my $pkg (keys %EXT_MAP) { 1632 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1187 if ($path =~ $EXT_MAP{$pkg}) { 1633 if ($path =~ $EXT_MAP{$pkg}[1]) {
1188 my $self = bless cf::map::new, $pkg; 1634 my $self = bless cf::map::new, $pkg;
1189 $self->{path} = $path; $self->path ($path); 1635 $self->{path} = $path; $self->path ($path);
1190 $self->init; # pass $1 etc. 1636 $self->init; # pass $1 etc.
1191 return $self; 1637 return $self;
1192 } 1638 }
1193 } 1639 }
1194 1640
1195 Carp::carp "unable to resolve path '$path'."; 1641 Carp::cluck "unable to resolve path '$path' (base '$base').";
1196 () 1642 ()
1197} 1643}
1198 1644
1199sub init { 1645sub init {
1200 my ($self) = @_; 1646 my ($self) = @_;
… …
1215 1661
1216# the original (read-only) location 1662# the original (read-only) location
1217sub load_path { 1663sub load_path {
1218 my ($self) = @_; 1664 my ($self) = @_;
1219 1665
1220 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path} 1666 "$MAPDIR/$self->{path}.map"
1221} 1667}
1222 1668
1223# the temporary/swap location 1669# the temporary/swap location
1224sub save_path { 1670sub save_path {
1225 my ($self) = @_; 1671 my ($self) = @_;
1226 1672
1227 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1673 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1228 sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $path 1674 "$TMPDIR/$path.map"
1229} 1675}
1230 1676
1231# the unique path, undef == no special unique path 1677# the unique path, undef == no special unique path
1232sub uniq_path { 1678sub uniq_path {
1233 my ($self) = @_; 1679 my ($self) = @_;
1234 1680
1235 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1681 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1236 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1682 "$UNIQUEDIR/$path"
1237} 1683}
1238 1684
1239# and all this just because we cannot iterate over 1685# and all this just because we cannot iterate over
1240# all maps in C++... 1686# all maps in C++...
1241sub change_all_map_light { 1687sub change_all_map_light {
… …
1243 1689
1244 $_->change_map_light ($change) 1690 $_->change_map_light ($change)
1245 for grep $_->outdoor, values %cf::MAP; 1691 for grep $_->outdoor, values %cf::MAP;
1246} 1692}
1247 1693
1694sub decay_objects {
1695 my ($self) = @_;
1696
1697 return if $self->{deny_reset};
1698
1699 $self->do_decay_objects;
1700}
1701
1248sub unlink_save { 1702sub unlink_save {
1249 my ($self) = @_; 1703 my ($self) = @_;
1250 1704
1251 utf8::encode (my $save = $self->save_path); 1705 utf8::encode (my $save = $self->save_path);
1252 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink $save; 1706 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1253 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink "$save.pst"; 1707 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1254} 1708}
1255 1709
1256sub load_header_from($) { 1710sub load_header_from($) {
1257 my ($self, $path) = @_; 1711 my ($self, $path) = @_;
1258 1712
1259 utf8::encode $path; 1713 utf8::encode $path;
1260 aio_open $path, O_RDONLY, 0 1714 #aio_open $path, O_RDONLY, 0
1261 or return; 1715 # or return;
1262 1716
1263 $self->_load_header ($path) 1717 $self->_load_header ($path)
1264 or return; 1718 or return;
1265 1719
1266 $self->{load_path} = $path; 1720 $self->{load_path} = $path;
1267 1721
1268 1 1722 1
1269} 1723}
1270 1724
1271sub load_orig { 1725sub load_header_orig {
1272 my ($self) = @_; 1726 my ($self) = @_;
1273 1727
1274 $self->load_header_from ($self->load_path) 1728 $self->load_header_from ($self->load_path)
1275} 1729}
1276 1730
1277sub load_temp { 1731sub load_header_temp {
1278 my ($self) = @_; 1732 my ($self) = @_;
1279 1733
1280 $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;
1281} 1754}
1282 1755
1283sub load_header { 1756sub load_header {
1284 my ($self) = @_; 1757 my ($self) = @_;
1285 1758
1286 if ($self->load_temp) { 1759 if ($self->load_header_temp) {
1287 $self->last_access ((delete $self->{last_access}) 1760 $self->prepare_temp;
1288 || $cf::RUNTIME); #d#
1289 # safety
1290 $self->{instantiate_time} = $cf::RUNTIME
1291 if $self->{instantiate_time} > $cf::RUNTIME;
1292 } else { 1761 } else {
1293 $self->load_orig 1762 $self->load_header_orig
1294 or return; 1763 or return;
1295 1764 $self->prepare_orig;
1296 $self->{load_original} = 1;
1297 $self->{instantiate_time} = $cf::RUNTIME;
1298 $self->last_access ($cf::RUNTIME);
1299 $self->instantiate;
1300 } 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;
1301 1772
1302 1 1773 1
1303} 1774}
1304 1775
1305sub find; 1776sub find;
… …
1318 $map->{last_save} = $cf::RUNTIME; 1789 $map->{last_save} = $cf::RUNTIME;
1319 1790
1320 $map->load_header 1791 $map->load_header
1321 or return; 1792 or return;
1322 1793
1323 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;
1324 $map->reset; 1797 $map->reset;
1325 undef $guard; 1798 undef $guard;
1326 $map = find $path 1799 return find $path;
1327 or return;
1328 } 1800 }
1329 1801
1330 $cf::MAP{$path} = $map 1802 $cf::MAP{$path} = $map
1331 } 1803 }
1332} 1804}
1805
1806sub pre_load { }
1807sub post_load { }
1333 1808
1334sub load { 1809sub load {
1335 my ($self) = @_; 1810 my ($self) = @_;
1336 1811
1812 local $self->{deny_reset} = 1; # loading can take a long time
1813
1337 my $path = $self->{path}; 1814 my $path = $self->{path};
1815
1816 {
1338 my $guard = cf::lock_acquire "map_load:$path"; 1817 my $guard = cf::lock_acquire "map_load:$path";
1339 1818
1340 return if $self->in_memory != cf::MAP_SWAPPED; 1819 return if $self->in_memory != cf::MAP_SWAPPED;
1341 1820
1342 $self->in_memory (cf::MAP_LOADING); 1821 $self->in_memory (cf::MAP_LOADING);
1343 1822
1344 $self->alloc; 1823 $self->alloc;
1345 $self->_load_objects ($self->{load_path}, 1)
1346 or return;
1347 1824
1348 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1825 $self->pre_load;
1349 if delete $self->{load_original};
1350
1351 if (my $uniq = $self->uniq_path) {
1352 utf8::encode $uniq;
1353 if (aio_open $uniq, O_RDONLY, 0) {
1354 $self->clear_unique_items;
1355 $self->_load_objects ($uniq, 0);
1356 }
1357 }
1358
1359 Coro::cede;
1360
1361 # now do the right thing for maps
1362 $self->link_multipart_objects;
1363
1364 unless ($self->{deny_activate}) {
1365 $self->decay_objects;
1366 $self->fix_auto_apply;
1367 $self->update_buttons;
1368 Coro::cede; 1826 Coro::cede;
1369 $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;
1370 $self->difficulty ($self->estimate_difficulty) 1845 $self->difficulty ($self->estimate_difficulty)
1371 unless $self->difficulty; 1846 unless $self->difficulty;
1372 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;
1373 $self->activate; 1856 $self->activate;
1374 } 1857 }
1375 1858
1376 $self->in_memory (cf::MAP_IN_MEMORY); 1859 $self->in_memory (cf::MAP_IN_MEMORY);
1860 }
1861
1862 $self->post_load;
1377} 1863}
1378 1864
1379sub customise_for { 1865sub customise_for {
1380 my ($self, $ob) = @_; 1866 my ($self, $ob) = @_;
1381 1867
1382 return find "~" . $ob->name . "/" . $self->{path} 1868 return find "~" . $ob->name . "/" . $self->{path}
1383 if $self->per_player; 1869 if $self->per_player;
1870
1871# return find "?party/" . $ob->name . "/" . $self->{path}
1872# if $self->per_party;
1384 1873
1385 $self 1874 $self
1386} 1875}
1387 1876
1388# 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
… …
1420 1909
1421 cf::sync_job { $map->load }; 1910 cf::sync_job { $map->load };
1422} 1911}
1423 1912
1424our %MAP_PREFETCH; 1913our %MAP_PREFETCH;
1425our $MAP_PREFETCHER = Coro::async { 1914our $MAP_PREFETCHER = undef;
1426 while () {
1427 for my $path (keys %MAP_PREFETCH) {
1428 my $map = find $path
1429 or next;
1430 $map->load;
1431
1432 delete $MAP_PREFETCH{$path};
1433 }
1434 Coro::schedule;
1435 }
1436};
1437 1915
1438sub find_async { 1916sub find_async {
1439 my ($path, $origin) = @_; 1917 my ($path, $origin) = @_;
1440 1918
1441 $path = normalise $path, $origin && $origin->{path}; 1919 $path = normalise $path, $origin && $origin->{path};
1442 1920
1443 if (my $map = $cf::MAP{$path}) { 1921 if (my $map = $cf::MAP{$path}) {
1444 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 1922 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1445 } 1923 }
1446 1924
1447 $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 };
1448 $MAP_PREFETCHER->ready; 1938 $MAP_PREFETCHER->prio (6);
1449 1939
1450 () 1940 ()
1451} 1941}
1452 1942
1453sub save { 1943sub save {
… …
1498 1988
1499sub reset_at { 1989sub reset_at {
1500 my ($self) = @_; 1990 my ($self) = @_;
1501 1991
1502 # TODO: safety, remove and allow resettable per-player maps 1992 # TODO: safety, remove and allow resettable per-player maps
1503 return 1e99 if $self->isa ("ext::map_per_player");
1504 return 1e99 if $self->{deny_reset}; 1993 return 1e99 if $self->{deny_reset};
1505 1994
1506 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1995 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1507 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;
1508 1997
… …
1513 my ($self) = @_; 2002 my ($self) = @_;
1514 2003
1515 $self->reset_at <= $cf::RUNTIME 2004 $self->reset_at <= $cf::RUNTIME
1516} 2005}
1517 2006
1518sub rename {
1519 my ($self, $new_path) = @_;
1520
1521 normalise $new_path;
1522
1523 $self->unlink_save;
1524
1525 delete $cf::MAP{$self->path};
1526 $self->{path} = $new_path; $self->path ($self->{path});
1527 $cf::MAP{$self->path} = $self;
1528
1529 $self->save;
1530}
1531
1532sub reset { 2007sub reset {
1533 my ($self) = @_; 2008 my ($self) = @_;
1534 2009
1535 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2010 my $lock = cf::lock_acquire "map_data:$self->{path}";
1536 2011
1537 return if $self->players; 2012 return if $self->players;
1538 return if $self->isa ("ext::map_per_player");#d#
1539 2013
1540 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 }
1541 2025
1542 delete $cf::MAP{$self->path}; 2026 delete $cf::MAP{$self->path};
1543 2027
1544 $self->in_memory (cf::MAP_SWAPPED);
1545 $self->clear; 2028 $self->clear;
1546 2029
1547 $_->clear_links_to ($self) for values %cf::MAP; 2030 $_->clear_links_to ($self) for values %cf::MAP;
1548 2031
1549 $self->unlink_save; 2032 $self->unlink_save;
… …
1553my $nuke_counter = "aaaa"; 2036my $nuke_counter = "aaaa";
1554 2037
1555sub nuke { 2038sub nuke {
1556 my ($self) = @_; 2039 my ($self) = @_;
1557 2040
2041 delete $cf::MAP{$self->path};
2042
2043 $self->unlink_save;
2044
2045 bless $self, "cf::map";
2046 delete $self->{deny_reset};
1558 $self->{deny_save} = 1; 2047 $self->{deny_save} = 1;
1559 $self->reset_timeout (1); 2048 $self->reset_timeout (1);
1560 $self->rename ("{nuke}/" . ($nuke_counter++)); 2049 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2050
2051 $cf::MAP{$self->path} = $self;
2052
1561 $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 ]
1562} 2090}
1563 2091
1564=item cf::map::unique_maps 2092=item cf::map::unique_maps
1565 2093
1566Returns an arrayref of paths of all shared maps that have 2094Returns an arrayref of paths of all shared maps that have
1567instantiated unique items. May block. 2095instantiated unique items. May block.
1568 2096
1569=cut 2097=cut
1570 2098
1571sub unique_maps() { 2099sub unique_maps() {
1572 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2100 [
1573 or return; 2101 map {
1574
1575 my @paths;
1576
1577 for (@$files) {
1578 utf8::decode $_; 2102 utf8::decode $_;
1579 next if /\.pst$/;
1580 next unless /^$PATH_SEP/o;
1581
1582 s/\.map$//; 2103 /\.map$/
1583 push @paths, $_; 2104 ? normalise $_
2105 : ()
2106 } @{ aio_readdir $UNIQUEDIR or [] }
1584 } 2107 ]
1585
1586 \@paths
1587} 2108}
1588 2109
1589package cf; 2110package cf;
1590 2111
1591=back 2112=back
… …
1637 2158
1638 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2159 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1639 2160
1640 if ($self->{record_replies}) { 2161 if ($self->{record_replies}) {
1641 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2162 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2163
1642 } 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 {
1643 $msg = $npc->name . " says: $msg" if $npc; 2177 $msg = $npc->name . " says: $msg" if $npc;
1644 $self->message ($msg, $flags); 2178 $self->message ($msg, $flags);
2179 }
1645 } 2180 }
1646} 2181}
1647 2182
1648=item $player_object->may ("access") 2183=item $player_object->may ("access")
1649 2184
… …
1682=cut 2217=cut
1683 2218
1684sub link_map { 2219sub link_map {
1685 unless ($LINK_MAP) { 2220 unless ($LINK_MAP) {
1686 $LINK_MAP = cf::map::find "{link}" 2221 $LINK_MAP = cf::map::find "{link}"
1687 or do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 }; 2222 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1688 $LINK_MAP->load; 2223 $LINK_MAP->load;
1689 } 2224 }
1690 2225
1691 $LINK_MAP 2226 $LINK_MAP
1692} 2227}
… …
1697 $self->deactivate_recursive; 2232 $self->deactivate_recursive;
1698 2233
1699 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2234 return if UNIVERSAL::isa $self->map, "ext::map_link";
1700 2235
1701 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2236 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1702 if $self->map; 2237 if $self->map && $self->map->{path} ne "{link}";
1703 2238
1704 $self->enter_map ($LINK_MAP || link_map, 20, 20); 2239 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1705} 2240}
1706 2241
1707sub cf::object::player::leave_link { 2242sub cf::object::player::leave_link {
1708 my ($self, $map, $x, $y) = @_; 2243 my ($self, $map, $x, $y) = @_;
2244
2245 return unless $self->contr->active;
1709 2246
1710 my $link_pos = delete $self->{_link_pos}; 2247 my $link_pos = delete $self->{_link_pos};
1711 2248
1712 unless ($map) { 2249 unless ($map) {
1713 # restore original map position 2250 # restore original map position
… …
1731 $map->load; 2268 $map->load;
1732 $map->load_diag; 2269 $map->load_diag;
1733 2270
1734 return unless $self->contr->active; 2271 return unless $self->contr->active;
1735 $self->activate_recursive; 2272 $self->activate_recursive;
2273
2274 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1736 $self->enter_map ($map, $x, $y); 2275 $self->enter_map ($map, $x, $y);
1737} 2276}
1738 2277
1739cf::player->attach ( 2278=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1740 on_logout => sub {
1741 my ($pl) = @_;
1742 2279
1743 # abort map switching before logout 2280Moves the player to the given map-path and coordinates by first freezing
1744 if ($pl->ob->{_link_pos}) { 2281her, loading and preparing them map, calling the provided $check callback
1745 cf::sync_job { 2282that has to return the map if sucecssful, and then unfreezes the player on
1746 $pl->ob->leave_link 2283the new (success) or old (failed) map position. In either case, $done will
1747 }; 2284be called at the end of this process.
1748 }
1749 },
1750 on_login => sub {
1751 my ($pl) = @_;
1752 2285
1753 # try to abort aborted map switching on player login :)
1754 # should happen only on crashes
1755 if ($pl->ob->{_link_pos}) {
1756 $pl->ob->enter_link;
1757 (async {
1758 # we need this sleep as the login has a concurrent enter_exit running
1759 # and this sleep increases chances of the player not ending up in scorn
1760 $pl->ob->reply (undef,
1761 "There was an internal problem at your last logout, "
1762 . "the server will try to bring you to your intended destination in a second.",
1763 cf::NDI_RED);
1764 Coro::Timer::sleep 1;
1765 $pl->ob->leave_link;
1766 })->prio (2);
1767 }
1768 },
1769);
1770
1771=item $player_object->goto ($path, $x, $y)
1772
1773=cut 2286=cut
2287
2288our $GOTOGEN;
1774 2289
1775sub cf::object::player::goto { 2290sub cf::object::player::goto {
1776 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;
1777 2295
1778 $self->enter_link; 2296 $self->enter_link;
1779 2297
1780 (async { 2298 (async {
2299 my $map = eval {
1781 my $map = cf::map::find $path; 2300 my $map = cf::map::find $path;
2301
2302 if ($map) {
1782 $map = $map->customise_for ($self) if $map; 2303 $map = $map->customise_for ($self);
1783 2304 $map = $check->($map) if $check && $map;
1784# warn "entering ", $map->path, " at ($x, $y)\n" 2305 } else {
1785# if $map;
1786
1787 $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 }
1788 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};
1789 $self->leave_link ($map, $x, $y); 2319 $self->leave_link ($map, $x, $y);
2320 }
2321
2322 $done->() if $done;
1790 })->prio (1); 2323 })->prio (1);
1791} 2324}
1792 2325
1793=item $player_object->enter_exit ($exit_object) 2326=item $player_object->enter_exit ($exit_object)
1794 2327
… …
1796 2329
1797sub parse_random_map_params { 2330sub parse_random_map_params {
1798 my ($spec) = @_; 2331 my ($spec) = @_;
1799 2332
1800 my $rmp = { # defaults 2333 my $rmp = { # defaults
1801 xsize => 10, 2334 xsize => (cf::rndm 15, 40),
1802 ysize => 10, 2335 ysize => (cf::rndm 15, 40),
2336 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2337 #layout => string,
1803 }; 2338 };
1804 2339
1805 for (split /\n/, $spec) { 2340 for (split /\n/, $spec) {
1806 my ($k, $v) = split /\s+/, $_, 2; 2341 my ($k, $v) = split /\s+/, $_, 2;
1807 2342
… …
1811 $rmp 2346 $rmp
1812} 2347}
1813 2348
1814sub prepare_random_map { 2349sub prepare_random_map {
1815 my ($exit) = @_; 2350 my ($exit) = @_;
2351
2352 my $guard = cf::lock_acquire "exit_prepare:$exit";
1816 2353
1817 # all this does is basically replace the /! path by 2354 # all this does is basically replace the /! path by
1818 # a new random map path (?random/...) with a seed 2355 # a new random map path (?random/...) with a seed
1819 # that depends on the exit object 2356 # that depends on the exit object
1820 2357
1821 my $rmp = parse_random_map_params $exit->msg; 2358 my $rmp = parse_random_map_params $exit->msg;
1822 2359
1823 if ($exit->map) { 2360 if ($exit->map) {
1824 $rmp->{region} = $exit->map->region_name; 2361 $rmp->{region} = $exit->region->name;
1825 $rmp->{origin_map} = $exit->map->path; 2362 $rmp->{origin_map} = $exit->map->path;
1826 $rmp->{origin_x} = $exit->x; 2363 $rmp->{origin_x} = $exit->x;
1827 $rmp->{origin_y} = $exit->y; 2364 $rmp->{origin_y} = $exit->y;
1828 } 2365 }
1829 2366
1830 $rmp->{random_seed} ||= $exit->random_seed; 2367 $rmp->{random_seed} ||= $exit->random_seed;
1831 2368
1832 my $data = cf::to_json $rmp; 2369 my $data = cf::to_json $rmp;
1833 my $md5 = Digest::MD5::md5_hex $data; 2370 my $md5 = Digest::MD5::md5_hex $data;
2371 my $meta = "$RANDOMDIR/$md5.meta";
1834 2372
1835 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) {
1836 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;
1837 2377
1838 $exit->slaying ("?random/$md5"); 2378 $exit->slaying ("?random/$md5");
1839 $exit->msg (undef); 2379 $exit->msg (undef);
1840 } 2380 }
1841} 2381}
… …
1843sub cf::object::player::enter_exit { 2383sub cf::object::player::enter_exit {
1844 my ($self, $exit) = @_; 2384 my ($self, $exit) = @_;
1845 2385
1846 return unless $self->type == cf::PLAYER; 2386 return unless $self->type == cf::PLAYER;
1847 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
1848 $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);
1849 2404
1850 (async { 2405 (async {
1851 $self->deactivate_recursive; # just to be sure 2406 $self->deactivate_recursive; # just to be sure
1852 unless (eval { 2407 unless (eval {
1853 prepare_random_map $exit 2408 $self->goto ($slaying, $hp, $sp);
1854 if $exit->slaying eq "/!";
1855
1856 my $path = new_from_path cf::map $exit->slaying, $exit->map && $exit->map->path;
1857 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1858 2409
1859 1; 2410 1;
1860 }) { 2411 }) {
1861 $self->message ("Something went wrong deep within the crossfire server. " 2412 $self->message ("Something went wrong deep within the crossfire server. "
1862 . "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. "
1863 . "Please report this to the dungeon master!", 2414 . "Please report this to the dungeon master!",
1864 cf::NDI_UNIQUE | cf::NDI_RED); 2415 cf::NDI_UNIQUE | cf::NDI_RED);
1865 2416
1866 warn "ERROR in enter_exit: $@"; 2417 warn "ERROR in enter_exit: $@";
1867 $self->leave_link; 2418 $self->leave_link;
1868 } 2419 }
1869 })->prio (1); 2420 })->prio (1);
… …
1882 2433
1883sub cf::client::send_drawinfo { 2434sub cf::client::send_drawinfo {
1884 my ($self, $text, $flags) = @_; 2435 my ($self, $text, $flags) = @_;
1885 2436
1886 utf8::encode $text; 2437 utf8::encode $text;
1887 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2438 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1888} 2439}
1889 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}
1890 2507
1891=item $success = $client->query ($flags, "text", \&cb) 2508=item $success = $client->query ($flags, "text", \&cb)
1892 2509
1893Queues a query to the client, calling the given callback with 2510Queues a query to the client, calling the given callback with
1894the 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>,
1895C<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>.
1896 2513
1897Queries 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
1898reliable at some point in the future. 2515become reliable at some point in the future.
1899 2516
1900=cut 2517=cut
1901 2518
1902sub cf::client::query { 2519sub cf::client::query {
1903 my ($self, $flags, $text, $cb) = @_; 2520 my ($self, $flags, $text, $cb) = @_;
… …
1911 utf8::encode $text; 2528 utf8::encode $text;
1912 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2529 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1913 2530
1914 $self->send_packet ($self->{query_queue}[0][0]) 2531 $self->send_packet ($self->{query_queue}[0][0])
1915 if @{ $self->{query_queue} } == 1; 2532 if @{ $self->{query_queue} } == 1;
2533
2534 1
1916} 2535}
1917 2536
1918cf::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 },
1919 on_reply => sub { 2543 on_reply => sub {
1920 my ($ns, $msg) = @_; 2544 my ($ns, $msg) = @_;
1921 2545
1922 # this weird shuffling is so that direct followup queries 2546 # this weird shuffling is so that direct followup queries
1923 # get handled first 2547 # get handled first
1924 my $queue = delete $ns->{query_queue} 2548 my $queue = delete $ns->{query_queue}
1925 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
1926 2550
1927 (shift @$queue)->[1]->($msg); 2551 (shift @$queue)->[1]->($msg);
2552 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1928 2553
1929 push @{ $ns->{query_queue} }, @$queue; 2554 push @{ $ns->{query_queue} }, @$queue;
1930 2555
1931 if (@{ $ns->{query_queue} } == @$queue) { 2556 if (@{ $ns->{query_queue} } == @$queue) {
1932 if (@$queue) { 2557 if (@$queue) {
… …
1934 } else { 2559 } else {
1935 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2560 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1936 } 2561 }
1937 } 2562 }
1938 }, 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 },
1939); 2582);
1940 2583
1941=item $client->async (\&cb) 2584=item $client->async (\&cb)
1942 2585
1943Create a new coroutine, running the specified callback. The coroutine will 2586Create a new coroutine, running the specified callback. The coroutine will
… …
1990 2633
1991# here we export the classes and methods available to script code 2634# here we export the classes and methods available to script code
1992 2635
1993=pod 2636=pod
1994 2637
1995The following fucntions and emthods are available within a safe environment: 2638The following functions and methods are available within a safe environment:
1996 2639
1997 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
1998 cf::object::player player 2644 cf::object::player
1999 cf::player peaceful 2645 player
2000 cf::map trigger 2646
2647 cf::player
2648 peaceful
2649
2650 cf::map
2651 trigger
2001 2652
2002=cut 2653=cut
2003 2654
2004for ( 2655for (
2005 ["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)],
2006 ["cf::object::player" => qw(player)], 2658 ["cf::object::player" => qw(player)],
2007 ["cf::player" => qw(peaceful)], 2659 ["cf::player" => qw(peaceful)],
2008 ["cf::map" => qw(trigger)], 2660 ["cf::map" => qw(trigger)],
2009) { 2661) {
2010 no strict 'refs'; 2662 no strict 'refs';
… …
2081=back 2733=back
2082 2734
2083=cut 2735=cut
2084 2736
2085############################################################################# 2737#############################################################################
2738# the server's init and main functions
2086 2739
2087=head2 EXTENSION DATABASE SUPPORT 2740sub load_facedata($) {
2741 my ($path) = @_;
2088 2742
2089Crossfire maintains a very simple database for extension use. It can 2743 warn "loading facedata from $path\n";
2090currently store anything that can be serialised using Storable, which
2091excludes objects.
2092 2744
2093The parameter C<$family> should best start with the name of the extension 2745 my $facedata;
2094using it, it should be unique. 2746 0 < aio_load $path, $facedata
2747 or die "$path: $!";
2095 2748
2096=over 4 2749 $facedata = Coro::Storable::thaw $facedata;
2097 2750
2098=item $hashref = cf::db_get $family 2751 $facedata->{version} == 2
2752 or cf::cleanup "$path: version mismatch, cannot proceed.";
2099 2753
2100Return a hashref for use by the extension C<$family>, which can be
2101modified. After modifications, you have to call C<cf::db_dirty> or
2102C<cf::db_sync>.
2103
2104=item $value = cf::db_get $family => $key
2105
2106Returns a single value from the database
2107
2108=item cf::db_put $family => $hashref
2109
2110Stores the given family hashref into the database. Updates are delayed, if
2111you want the data to be synced to disk immediately, use C<cf::db_sync>.
2112
2113=item cf::db_put $family => $key => $value
2114
2115Stores the given C<$value> in the family hash. Updates are delayed, if you
2116want the data to be synced to disk immediately, use C<cf::db_sync>.
2117
2118=item cf::db_dirty
2119
2120Marks the database as dirty, to be updated at a later time.
2121
2122=item cf::db_sync
2123
2124Immediately write the database to disk I<if it is dirty>.
2125
2126=cut
2127
2128our $DB;
2129
2130{
2131 my $path = cf::localdir . "/database.pst";
2132
2133 sub db_load() {
2134 $DB = stat $path ? Storable::retrieve $path : { };
2135 } 2754 {
2755 my $faces = $facedata->{faceinfo};
2136 2756
2137 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};
2138 2763
2139 sub db_save() { 2764 cf::cede_to_tick;
2140 waitpid $pid, 0 if $pid;
2141 if (0 == ($pid = fork)) {
2142 $DB->{_meta}{version} = 1;
2143 Storable::nstore $DB, "$path~";
2144 rename "$path~", $path;
2145 cf::_exit 0 if defined $pid;
2146 }
2147 }
2148
2149 my $dirty;
2150
2151 sub db_sync() {
2152 db_save if $dirty;
2153 undef $dirty;
2154 }
2155
2156 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
2157 db_sync;
2158 });
2159
2160 sub db_dirty() {
2161 $dirty = 1;
2162 $idle->start;
2163 }
2164
2165 sub db_get($;$) {
2166 @_ >= 2
2167 ? $DB->{$_[0]}{$_[1]}
2168 : ($DB->{$_[0]} ||= { })
2169 }
2170
2171 sub db_put($$;$) {
2172 if (@_ >= 3) {
2173 $DB->{$_[0]}{$_[1]} = $_[2];
2174 } else {
2175 $DB->{$_[0]} = $_[1];
2176 }
2177 db_dirty;
2178 }
2179
2180 cf::global->attach (
2181 prio => 10000,
2182 on_cleanup => sub {
2183 db_sync;
2184 }, 2765 }
2185 );
2186}
2187 2766
2188############################################################################# 2767 while (my ($face, $info) = each %$faces) {
2189# 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}
2190 2871
2191sub cfg_load { 2872sub cfg_load {
2192 open my $fh, "<:utf8", cf::confdir . "/config" 2873 open my $fh, "<:utf8", "$CONFDIR/config"
2193 or return; 2874 or return;
2194 2875
2195 local $/; 2876 local $/;
2196 *CFG = YAML::Syck::Load <$fh>; 2877 *CFG = YAML::Syck::Load <$fh>;
2197 2878
… …
2211 2892
2212sub main { 2893sub main {
2213 # we must not ever block the main coroutine 2894 # we must not ever block the main coroutine
2214 local $Coro::idle = sub { 2895 local $Coro::idle = sub {
2215 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 {
2216 async { Event::one_event }; 2898 Event::one_event;
2899 })->prio (Coro::PRIO_MAX);
2217 }; 2900 };
2218 2901
2219 cfg_load; 2902 cfg_load;
2220 db_load; 2903 db_init;
2221 load_extensions; 2904 load_extensions;
2905
2906 $TICK_WATCHER->start;
2222 Event::loop; 2907 Event::loop;
2223} 2908}
2224 2909
2225############################################################################# 2910#############################################################################
2226# initialisation and cleanup 2911# initialisation and cleanup
2227 2912
2228# install some emergency cleanup handlers 2913# install some emergency cleanup handlers
2229BEGIN { 2914BEGIN {
2230 for my $signal (qw(INT HUP TERM)) { 2915 for my $signal (qw(INT HUP TERM)) {
2231 Event->signal ( 2916 Event->signal (
2917 reentrant => 0,
2232 data => WF_AUTOCANCEL, 2918 data => WF_AUTOCANCEL,
2233 signal => $signal, 2919 signal => $signal,
2920 prio => 0,
2234 cb => sub { 2921 cb => sub {
2235 cf::cleanup "SIG$signal"; 2922 cf::cleanup "SIG$signal";
2236 }, 2923 },
2237 ); 2924 );
2238 } 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
2239} 2964}
2240 2965
2241sub emergency_save() { 2966sub emergency_save() {
2242 my $freeze_guard = cf::freeze_mainloop; 2967 my $freeze_guard = cf::freeze_mainloop;
2243 2968
… …
2260 my $map = $cf::MAP{$path} or next; 2985 my $map = $cf::MAP{$path} or next;
2261 $map->valid or next; 2986 $map->valid or next;
2262 $map->save; 2987 $map->save;
2263 } 2988 }
2264 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";
2265 }; 2994 };
2266 2995
2267 warn "leave emergency perl save\n"; 2996 warn "leave emergency perl save\n";
2268} 2997}
2269 2998
2999sub post_cleanup {
3000 my ($make_core) = @_;
3001
3002 warn Carp::longmess "post_cleanup backtrace"
3003 if $make_core;
3004}
3005
2270sub reload() { 3006sub do_reload_perl() {
2271 # can/must only be called in main 3007 # can/must only be called in main
2272 if ($Coro::current != $Coro::main) { 3008 if ($Coro::current != $Coro::main) {
2273 warn "can only reload from main coroutine\n"; 3009 warn "can only reload from main coroutine";
2274 return; 3010 return;
2275 } 3011 }
2276 3012
2277 warn "reloading..."; 3013 warn "reloading...";
2278 3014
2279 warn "freezing server"; 3015 warn "entering sync_job";
2280 my $guard = freeze_mainloop; 3016
3017 cf::sync_job {
3018 cf::write_runtime; # external watchdog should not bark
2281 cf::emergency_save; 3019 cf::emergency_save;
3020 cf::write_runtime; # external watchdog should not bark
2282 3021
2283 warn "sync database to disk"; 3022 warn "syncing database to disk";
2284 cf::db_sync; 3023 BDB::db_env_txn_checkpoint $DB_ENV;
2285 IO::AIO::flush;
2286 3024
2287 eval {
2288 # 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
2289 3026
2290 warn "cancel all watchers"; 3027 warn "cancelling all WF_AUTOCANCEL watchers";
2291 for (Event::all_watchers) { 3028 for (Event::all_watchers) {
2292 $_->cancel if $_->data & WF_AUTOCANCEL; 3029 $_->cancel if $_->data & WF_AUTOCANCEL;
2293 } 3030 }
2294 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
2295 warn "cancel all extension coros"; 3043 warn "cancelling all extension coros";
2296 $_->cancel for values %EXT_CORO; 3044 $_->cancel for values %EXT_CORO;
2297 %EXT_CORO = (); 3045 %EXT_CORO = ();
2298 3046
2299 warn "remove commands"; 3047 warn "removing commands";
2300 %COMMAND = (); 3048 %COMMAND = ();
2301 3049
2302 warn "remove ext commands"; 3050 warn "removing ext/exti commands";
2303 %EXTCMD = (); 3051 %EXTCMD = ();
3052 %EXTICMD = ();
2304 3053
2305 warn "unload/nuke all extensions"; 3054 warn "unloading/nuking all extensions";
2306 for my $pkg (@EXTS) { 3055 for my $pkg (@EXTS) {
2307 warn "... unloading $pkg"; 3056 warn "... unloading $pkg";
2308 3057
2309 if (my $cb = $pkg->can ("unload")) { 3058 if (my $cb = $pkg->can ("unload")) {
2310 eval { 3059 eval {
… …
2315 3064
2316 warn "... nuking $pkg"; 3065 warn "... nuking $pkg";
2317 Symbol::delete_package $pkg; 3066 Symbol::delete_package $pkg;
2318 } 3067 }
2319 3068
2320 warn "unload all perl modules loaded from $LIBDIR"; 3069 warn "unloading all perl modules loaded from $LIBDIR";
2321 while (my ($k, $v) = each %INC) { 3070 while (my ($k, $v) = each %INC) {
2322 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3071 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2323 3072
2324 warn "removing <$k>"; 3073 warn "... unloading $k";
2325 delete $INC{$k}; 3074 delete $INC{$k};
2326 3075
2327 $k =~ s/\.pm$//; 3076 $k =~ s/\.pm$//;
2328 $k =~ s/\//::/g; 3077 $k =~ s/\//::/g;
2329 3078
… …
2332 } 3081 }
2333 3082
2334 Symbol::delete_package $k; 3083 Symbol::delete_package $k;
2335 } 3084 }
2336 3085
2337 warn "get rid of safe::, as good as possible"; 3086 warn "getting rid of safe::, as good as possible";
2338 Symbol::delete_package "safe::$_" 3087 Symbol::delete_package "safe::$_"
2339 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);
2340 3089
2341 warn "unload cf.pm \"a bit\""; 3090 warn "unloading cf.pm \"a bit\"";
2342 delete $INC{"cf.pm"}; 3091 delete $INC{"cf.pm"};
3092 delete $INC{"cf/pod.pm"};
2343 3093
2344 # don't, removes xs symbols, too, 3094 # don't, removes xs symbols, too,
2345 # and global variables created in xs 3095 # and global variables created in xs
2346 #Symbol::delete_package __PACKAGE__; 3096 #Symbol::delete_package __PACKAGE__;
2347 3097
3098 warn "unload completed, starting to reload now";
3099
2348 warn "reloading cf.pm"; 3100 warn "reloading cf.pm";
2349 require cf; 3101 require cf;
2350 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3102 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2351 3103
2352 warn "load config and database again"; 3104 warn "loading config and database again";
2353 cf::cfg_load; 3105 cf::cfg_load;
2354 cf::db_load;
2355 3106
2356 warn "load extensions"; 3107 warn "loading extensions";
2357 cf::load_extensions; 3108 cf::load_extensions;
2358 3109
2359 warn "reattach attachments to objects/players"; 3110 warn "reattaching attachments to objects/players";
2360 _global_reattach; 3111 _global_reattach; # objects, sockets
2361 warn "reattach attachments to maps"; 3112 warn "reattaching attachments to maps";
2362 reattach $_ for values %MAP; 3113 reattach $_ for values %MAP;
2363 }; 3114 warn "reattaching attachments to players";
3115 reattach $_ for values %PLAYER;
2364 3116
2365 if ($@) { 3117 warn "leaving sync_job";
3118
3119 1
3120 } or do {
2366 warn $@; 3121 warn $@;
2367 warn "error while reloading, exiting."; 3122 warn "error while reloading, exiting.";
2368 exit 1; 3123 exit 1;
2369 } 3124 };
2370 3125
2371 warn "reloaded"; 3126 warn "reloaded";
2372}; 3127};
2373 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
2374register_command "reload" => sub { 3146register_command "reload" => sub {
2375 my ($who, $arg) = @_; 3147 my ($who, $arg) = @_;
2376 3148
2377 if ($who->flag (FLAG_WIZ)) { 3149 if ($who->flag (FLAG_WIZ)) {
2378 $who->message ("start of reload.");
2379 reload;
2380 $who->message ("end of reload."); 3150 $who->message ("reloading server.");
3151 async { reload_perl };
2381 } 3152 }
2382}; 3153};
2383 3154
2384unshift @INC, $LIBDIR; 3155unshift @INC, $LIBDIR;
2385 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;
2386$TICK_WATCHER = Event->timer ( 3182$TICK_WATCHER = Event->timer (
2387 reentrant => 0, 3183 reentrant => 0,
3184 parked => 1,
2388 prio => 0, 3185 prio => 0,
2389 at => $NEXT_TICK || $TICK, 3186 at => $NEXT_TICK || $TICK,
2390 data => WF_AUTOCANCEL, 3187 data => WF_AUTOCANCEL,
2391 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
2392 $NOW = Event::time; 3195 $NOW = $tick_start = Event::time;
2393 3196
2394 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
2395 $RUNTIME += $TICK; 3222 $RUNTIME += $TICK;
2396 $NEXT_TICK += $TICK; 3223 $NEXT_TICK += $TICK;
2397 3224
2398 $WAIT_FOR_TICK->broadcast; 3225 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2399 $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;
2400 3244
2401 # 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
2402 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3246 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2403 3247
2404 $TICK_WATCHER->at ($NEXT_TICK); 3248 $TICK_WATCHER->at ($NEXT_TICK);
2405 $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
2406 }, 3257 },
2407); 3258);
2408 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;
2409IO::AIO::max_poll_time $TICK * 0.2; 3314 IO::AIO::max_poll_time $TICK * 0.1;
2410
2411$AIO_POLL_WATCHER = Event->io ( 3315 $AIO_POLL_WATCHER = Event->io (
2412 fd => IO::AIO::poll_fileno, 3316 reentrant => 0,
2413 poll => 'r',
2414 prio => 5,
2415 data => WF_AUTOCANCEL,
2416 cb => \&IO::AIO::poll_cb,
2417);
2418
2419$WRITE_RUNTIME_WATCHER = Event->timer (
2420 data => WF_AUTOCANCEL, 3317 data => WF_AUTOCANCEL,
2421 after => 0, 3318 fd => IO::AIO::poll_fileno,
2422 interval => 10, 3319 poll => 'r',
2423 cb => sub { 3320 prio => 6,
2424 (Coro::unblock_sub { 3321 cb => \&IO::AIO::poll_cb,
2425 write_runtime 3322 );
2426 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;
2427 })->(); 3356 };
3357 } else {
3358 LOG llevInfo, "[ABT] $msg\n";
3359 LOG llevInfo, "[ABT] [suppressed]\n";
2428 }, 3360 }
2429); 3361}
3362
3363# load additional modules
3364use cf::pod;
2430 3365
2431END { cf::emergency_save } 3366END { cf::emergency_save }
2432 3367
24331 33681
2434 3369

Diff Legend

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