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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines