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

Diff Legend

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