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.237 by root, Fri Apr 13 05:08:51 2007 UTC vs.
Revision 1.331 by root, Mon Aug 13 13:10:01 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;
9use Event; 10use Event;
10use Opcode; 11use Opcode;
11use Safe; 12use Safe;
12use Safe::Hole; 13use Safe::Hole;
13 14
14use Coro 3.52 (); 15use Coro 3.61 ();
15use Coro::State; 16use Coro::State;
17use Coro::Handle;
16use Coro::Event; 18use Coro::Event;
17use Coro::Timer; 19use Coro::Timer;
18use Coro::Signal; 20use Coro::Signal;
19use Coro::Semaphore; 21use Coro::Semaphore;
20use Coro::AIO; 22use Coro::AIO;
21use Coro::Storable; 23use Coro::Storable;
22 24
25use JSON::XS 1.4 ();
23use BDB (); 26use BDB ();
24use Data::Dumper; 27use Data::Dumper;
25use Digest::MD5; 28use Digest::MD5;
26use Fcntl; 29use Fcntl;
27use YAML::Syck (); 30use YAML::Syck ();
28use IO::AIO 2.32 (); 31use IO::AIO 2.32 ();
29use Time::HiRes; 32use Time::HiRes;
30use Compress::LZF; 33use Compress::LZF;
34use Digest::MD5 ();
31 35
32# configure various modules to our taste 36# configure various modules to our taste
33# 37#
34$Storable::canonical = 1; # reduce rsync transfers 38$Storable::canonical = 1; # reduce rsync transfers
35Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 39Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
47our %COMMAND = (); 51our %COMMAND = ();
48our %COMMAND_TIME = (); 52our %COMMAND_TIME = ();
49 53
50our @EXTS = (); # list of extension package names 54our @EXTS = (); # list of extension package names
51our %EXTCMD = (); 55our %EXTCMD = ();
56our %EXTICMD = ();
52our %EXT_CORO = (); # coroutines bound to extensions 57our %EXT_CORO = (); # coroutines bound to extensions
53our %EXT_MAP = (); # pluggable maps 58our %EXT_MAP = (); # pluggable maps
54 59
55our $RELOAD; # number of reloads so far 60our $RELOAD; # number of reloads so far
56our @EVENT; 61our @EVENT;
57our $LIBDIR = datadir . "/ext";
58 62
59our $TICK = MAX_TIME * 1e-6; 63our $CONFDIR = confdir;
64our $DATADIR = datadir;
65our $LIBDIR = "$DATADIR/ext";
66our $PODDIR = "$DATADIR/pod";
67our $MAPDIR = "$DATADIR/" . mapdir;
68our $LOCALDIR = localdir;
69our $TMPDIR = "$LOCALDIR/" . tmpdir;
70our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
71our $PLAYERDIR = "$LOCALDIR/" . playerdir;
72our $RANDOMDIR = "$LOCALDIR/random";
73our $BDBDIR = "$LOCALDIR/db";
74
75our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
60our $TICK_WATCHER; 76our $TICK_WATCHER;
61our $AIO_POLL_WATCHER; 77our $AIO_POLL_WATCHER;
62our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 78our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
63our $NEXT_TICK; 79our $NEXT_TICK;
64our $NOW; 80our $NOW;
73our $RUNTIME; 89our $RUNTIME;
74 90
75our %PLAYER; # all users 91our %PLAYER; # all users
76our %MAP; # all maps 92our %MAP; # all maps
77our $LINK_MAP; # the special {link} map, which is always available 93our $LINK_MAP; # the special {link} map, which is always available
78our $RANDOM_MAPS = cf::localdir . "/random";
79our $BDB_ENV_DIR = cf::localdir . "/db";
80
81our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
82our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
83 94
84# used to convert map paths into valid unix filenames by replacing / by ∕ 95# used to convert map paths into valid unix filenames by replacing / by ∕
85our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 96our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
86 97
98our $LOAD; # a number between 0 (idle) and 1 (too many objects)
99our $LOADAVG; # same thing, but with alpha-smoothing
100our $tick_start; # for load detecting purposes
101
87binmode STDOUT; 102binmode STDOUT;
88binmode STDERR; 103binmode STDERR;
89 104
90# read virtual server time, if available 105# read virtual server time, if available
91unless ($RUNTIME || !-e cf::localdir . "/runtime") { 106unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
92 open my $fh, "<", cf::localdir . "/runtime" 107 open my $fh, "<", "$LOCALDIR/runtime"
93 or die "unable to read runtime file: $!"; 108 or die "unable to read runtime file: $!";
94 $RUNTIME = <$fh> + 0.; 109 $RUNTIME = <$fh> + 0.;
95} 110}
96 111
97mkdir cf::localdir; 112mkdir $_
98mkdir cf::localdir . "/" . cf::playerdir; 113 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
99mkdir cf::localdir . "/" . cf::tmpdir;
100mkdir cf::localdir . "/" . cf::uniquedir;
101mkdir $RANDOM_MAPS;
102mkdir $BDB_ENV_DIR;
103 114
104our $EMERGENCY_POSITION; 115our $EMERGENCY_POSITION;
105 116
106sub cf::map::normalise; 117sub cf::map::normalise;
107 118
118=item $cf::RUNTIME 129=item $cf::RUNTIME
119 130
120The time this server has run, starts at 0 and is increased by $cf::TICK on 131The time this server has run, starts at 0 and is increased by $cf::TICK on
121every server tick. 132every server tick.
122 133
123=item $cf::LIBDIR 134=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
135$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
136$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
124 137
125The perl library directory, where extensions and cf-specific modules can 138Various directories - "/etc", read-only install directory, perl-library
126be found. It will be added to C<@INC> automatically. 139directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
140unique-items directory, player file directory, random maps directory and
141database environment.
127 142
128=item $cf::NOW 143=item $cf::NOW
129 144
130The time of the last (current) server tick. 145The time of the last (current) server tick.
131 146
132=item $cf::TICK 147=item $cf::TICK
133 148
134The interval between server ticks, in seconds. 149The interval between server ticks, in seconds.
150
151=item $cf::LOADAVG
152
153The current CPU load on the server (alpha-smoothed), as a value between 0
154(none) and 1 (overloaded), indicating how much time is spent on processing
155objects per tick. Healthy values are < 0.5.
156
157=item $cf::LOAD
158
159The raw value load value from the last tick.
135 160
136=item %cf::CFG 161=item %cf::CFG
137 162
138Configuration for the server, loaded from C</etc/crossfire/config>, or 163Configuration for the server, loaded from C</etc/crossfire/config>, or
139from wherever your confdir points to. 164from wherever your confdir points to.
140 165
141=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 166=item cf::wait_for_tick, cf::wait_for_tick_begin
142 167
143These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK) 168These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
144or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick 169returns directly I<after> the tick processing (and consequently, can only wake one process
145processing has been done. Call C<< ->wait >> on them to maximise the 170per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
146window of cpu time available, or simply to synchronise to the server tick. 171
172=item @cf::INVOKE_RESULTS
173
174This array contains the results of the last C<invoke ()> call. When
175C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
176that call.
147 177
148=back 178=back
149 179
150=cut 180=cut
151 181
152BEGIN { 182BEGIN {
153 *CORE::GLOBAL::warn = sub { 183 *CORE::GLOBAL::warn = sub {
154 my $msg = join "", @_; 184 my $msg = join "", @_;
155 utf8::encode $msg;
156 185
157 $msg .= "\n" 186 $msg .= "\n"
158 unless $msg =~ /\n$/; 187 unless $msg =~ /\n$/;
159 188
189 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
190
191 utf8::encode $msg;
160 LOG llevError, $msg; 192 LOG llevError, $msg;
161 }; 193 };
162} 194}
163 195
164@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 196@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
165@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 197@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
166@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 198@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
167@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 199@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
168@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 200@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
201@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
169@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 202@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
170 203
171# we bless all objects into (empty) derived classes to force a method lookup 204# we bless all objects into (empty) derived classes to force a method lookup
172# within the Safe compartment. 205# within the Safe compartment.
173for my $pkg (qw( 206for my $pkg (qw(
174 cf::global cf::attachable 207 cf::global cf::attachable
182} 215}
183 216
184$Event::DIED = sub { 217$Event::DIED = sub {
185 warn "error in event callback: @_"; 218 warn "error in event callback: @_";
186}; 219};
220
221#############################################################################
187 222
188=head2 UTILITY FUNCTIONS 223=head2 UTILITY FUNCTIONS
189 224
190=over 4 225=over 4
191 226
210 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 245 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
211 $d 246 $d
212 } || "[unable to dump $_[0]: '$@']"; 247 } || "[unable to dump $_[0]: '$@']";
213} 248}
214 249
215use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
216
217=item $ref = cf::from_json $json 250=item $ref = cf::from_json $json
218 251
219Converts a JSON string into the corresponding perl data structure. 252Converts a JSON string into the corresponding perl data structure.
220 253
221=item $json = cf::to_json $ref 254=item $json = cf::to_json $ref
222 255
223Converts a perl data structure into its JSON representation. 256Converts a perl data structure into its JSON representation.
257
258=cut
259
260our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
261
262sub to_json ($) { $json_coder->encode ($_[0]) }
263sub from_json ($) { $json_coder->decode ($_[0]) }
224 264
225=item cf::lock_wait $string 265=item cf::lock_wait $string
226 266
227Wait until the given lock is available. See cf::lock_acquire. 267Wait until the given lock is available. See cf::lock_acquire.
228 268
234returned. 274returned.
235 275
236Lock names should begin with a unique identifier (for example, cf::map::find 276Lock names should begin with a unique identifier (for example, cf::map::find
237uses map_find and cf::map::load uses map_load). 277uses map_find and cf::map::load uses map_load).
238 278
279=item $locked = cf::lock_active $string
280
281Return true if the lock is currently active, i.e. somebody has locked it.
282
239=cut 283=cut
240 284
241our %LOCK; 285our %LOCK;
242 286
243sub lock_wait($) { 287sub lock_wait($) {
260 304
261 Coro::guard { 305 Coro::guard {
262 # wake up all waiters, to be on the safe side 306 # wake up all waiters, to be on the safe side
263 $_->ready for @{ delete $LOCK{$key} }; 307 $_->ready for @{ delete $LOCK{$key} };
264 } 308 }
309}
310
311sub lock_active($) {
312 my ($key) = @_;
313
314 ! ! $LOCK{$key}
265} 315}
266 316
267sub freeze_mainloop { 317sub freeze_mainloop {
268 return unless $TICK_WATCHER->is_active; 318 return unless $TICK_WATCHER->is_active;
269 319
272 }; 322 };
273 $TICK_WATCHER->stop; 323 $TICK_WATCHER->stop;
274 $guard 324 $guard
275} 325}
276 326
327=item cf::get_slot $time[, $priority[, $name]]
328
329Allocate $time seconds of blocking CPU time at priority C<$priority>:
330This call blocks and returns only when you have at least C<$time> seconds
331of cpu time till the next tick. The slot is only valid till the next cede.
332
333The optional C<$name> can be used to identify the job to run. It might be
334used for statistical purposes and should identify the same time-class.
335
336Useful for short background jobs.
337
338=cut
339
340our @SLOT_QUEUE;
341our $SLOT_QUEUE;
342
343$SLOT_QUEUE->cancel if $SLOT_QUEUE;
344$SLOT_QUEUE = Coro::async {
345 my $signal = new Coro::Signal;
346
347 while () {
348 next_job:
349 my $avail = cf::till_tick;
350 if ($avail > 0.01) {
351 for (0 .. $#SLOT_QUEUE) {
352 if ($SLOT_QUEUE[$_][0] < $avail) {
353 my $job = splice @SLOT_QUEUE, $_, 1, ();
354 $job->[2]->send;
355 Coro::cede;
356 goto next_job;
357 }
358 }
359 }
360
361 if (@SLOT_QUEUE) {
362 # we do not use wait_For_tick() as it returns immediately when tick is inactive
363 push @cf::WAIT_FOR_TICK, $signal;
364 $signal->wait;
365 } else {
366 Coro::schedule;
367 }
368 }
369};
370
371sub get_slot($;$$) {
372 my ($time, $pri, $name) = @_;
373
374 $time = $TICK * .6 if $time > $TICK * .6;
375 my $sig = new Coro::Signal;
376
377 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
378 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
379 $SLOT_QUEUE->ready;
380 $sig->wait;
381}
382
277=item cf::async { BLOCK } 383=item cf::async { BLOCK }
278 384
279Currently the same as Coro::async_pool, meaning you cannot use 385Currently the same as Coro::async_pool, meaning you cannot use
280C<on_destroy>, C<join> or other gimmicks on these coroutines. The only 386C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
281thing you are allowed to do is call C<prio> on it. 387thing you are allowed to do is call C<prio> on it.
284 390
285BEGIN { *async = \&Coro::async_pool } 391BEGIN { *async = \&Coro::async_pool }
286 392
287=item cf::sync_job { BLOCK } 393=item cf::sync_job { BLOCK }
288 394
289The design of crossfire+ requires that the main coro ($Coro::main) is 395The design of Crossfire TRT requires that the main coroutine ($Coro::main)
290always able to handle events or runnable, as crossfire+ is only partly 396is always able to handle events or runnable, as Crossfire TRT is only
291reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 397partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
398acceptable.
292 399
293If it must be done, put the blocking parts into C<sync_job>. This will run 400If it must be done, put the blocking parts into C<sync_job>. This will run
294the given BLOCK in another coroutine while waiting for the result. The 401the given BLOCK in another coroutine while waiting for the result. The
295server will be frozen during this time, so the block should either finish 402server will be frozen during this time, so the block should either finish
296fast or be very important. 403fast or be very important.
299 406
300sub sync_job(&) { 407sub sync_job(&) {
301 my ($job) = @_; 408 my ($job) = @_;
302 409
303 if ($Coro::current == $Coro::main) { 410 if ($Coro::current == $Coro::main) {
411 my $time = Event::time;
412
304 # this is the main coro, too bad, we have to block 413 # this is the main coro, too bad, we have to block
305 # till the operation succeeds, freezing the server :/ 414 # till the operation succeeds, freezing the server :/
306 415
307 # TODO: use suspend/resume instead 416 # TODO: use suspend/resume instead
308 # (but this is cancel-safe) 417 # (but this is cancel-safe)
319 428
320 while ($busy) { 429 while ($busy) {
321 Coro::cede or Event::one_event; 430 Coro::cede or Event::one_event;
322 } 431 }
323 432
433 $time = Event::time - $time;
434
435 LOG llevError | logBacktrace, Carp::longmess "long sync job"
436 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
437
438 $tick_start += $time; # do not account sync jobs to server load
439
324 wantarray ? @res : $res[0] 440 wantarray ? @res : $res[0]
325 } else { 441 } else {
326 # we are in another coroutine, how wonderful, everything just works 442 # we are in another coroutine, how wonderful, everything just works
327 443
328 $job->() 444 $job->()
347 $EXT_CORO{$coro+0} = $coro; 463 $EXT_CORO{$coro+0} = $coro;
348 464
349 $coro 465 $coro
350} 466}
351 467
352sub write_runtime { 468=item fork_call { }, $args
353 my $guard = cf::lock_acquire "write_runtime";
354 469
355 my $runtime = cf::localdir . "/runtime"; 470Executes the given code block with the given arguments in a seperate
471process, returning the results. Everything must be serialisable with
472Coro::Storable. May, of course, block. Note that the executed sub may
473never block itself or use any form of Event handling.
356 474
357 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 475=cut
358 or return;
359 476
360 my $value = $cf::RUNTIME + 90 + 10; 477sub _store_scalar {
361 # 10 is the runtime save interval, for a monotonic clock 478 open my $fh, ">", \my $buf
362 # 60 allows for the watchdog to kill the server. 479 or die "fork_call: cannot open fh-to-buf in child : $!";
363 480 Storable::store_fd $_[0], $fh;
364 (aio_write $fh, 0, (length $value), $value, 0) <= 0
365 and return;
366
367 # always fsync - this file is important
368 aio_fsync $fh
369 and return;
370
371 close $fh 481 close $fh;
372 or return;
373 482
374 aio_rename "$runtime~", $runtime 483 $buf
375 and return; 484}
376 485
486sub fork_call(&@) {
487 my ($cb, @args) = @_;
488
489# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
490# or die "socketpair: $!";
491 pipe my $fh1, my $fh2
492 or die "pipe: $!";
493
494 if (my $pid = fork) {
495 close $fh2;
496
497 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
498 warn "pst<$res>" unless $res =~ /^pst/;
499 $res = Coro::Storable::thaw $res;
500
501 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
502
503 Carp::confess $$res unless "ARRAY" eq ref $res;
504
505 return wantarray ? @$res : $res->[-1];
506 } else {
507 reset_signals;
508 local $SIG{__WARN__};
509 local $SIG{__DIE__};
510 # just in case, this hack effectively disables event
511 # in the child. cleaner and slower would be canceling all watchers,
512 # but this works for the time being.
513 local $Coro::idle;
514 $Coro::current->prio (Coro::PRIO_MAX);
515
516 eval {
517 close $fh1;
518
519 my @res = eval { $cb->(@args) };
520
521 syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
522 close $fh2;
523 };
524
525 warn $@ if $@;
526 _exit 0;
377 1 527 }
528}
529
530=item $value = cf::db_get $family => $key
531
532Returns a single value from the environment database.
533
534=item cf::db_put $family => $key => $value
535
536Stores the given C<$value> in the family. It can currently store binary
537data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
538
539=cut
540
541our $DB;
542
543sub db_init {
544 unless ($DB) {
545 $DB = BDB::db_create $DB_ENV;
546
547 cf::sync_job {
548 eval {
549 $DB->set_flags (BDB::CHKSUM);
550
551 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
552 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
553 cf::cleanup "db_open(db): $!" if $!;
554 };
555 cf::cleanup "db_open(db): $@" if $@;
556 };
557 }
558}
559
560sub db_get($$) {
561 my $key = "$_[0]/$_[1]";
562
563 cf::sync_job {
564 BDB::db_get $DB, undef, $key, my $data;
565
566 $! ? ()
567 : $data
568 }
569}
570
571sub db_put($$$) {
572 BDB::dbreq_pri 4;
573 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
574}
575
576=item cf::cache $id => [$paths...], $processversion => $process
577
578Generic caching function that returns the value of the resource $id,
579caching and regenerating as required.
580
581This function can block.
582
583=cut
584
585sub cache {
586 my ($id, $src, $processversion, $process) = @_;
587
588 my $meta =
589 join "\x00",
590 $processversion,
591 map {
592 aio_stat $_
593 and Carp::croak "$_: $!";
594
595 ($_, (stat _)[7,9])
596 } @$src;
597
598 my $dbmeta = db_get cache => "$id/meta";
599 if ($dbmeta ne $meta) {
600 # changed, we may need to process
601
602 my @data;
603 my $md5;
604
605 for (0 .. $#$src) {
606 0 <= aio_load $src->[$_], $data[$_]
607 or Carp::croak "$src->[$_]: $!";
608 }
609
610 # if processing is expensive, check
611 # checksum first
612 if (1) {
613 $md5 =
614 join "\x00",
615 $processversion,
616 map {
617 Coro::cede;
618 ($src->[$_], Digest::MD5::md5_hex $data[$_])
619 } 0.. $#$src;
620
621
622 my $dbmd5 = db_get cache => "$id/md5";
623 if ($dbmd5 eq $md5) {
624 db_put cache => "$id/meta", $meta;
625
626 return db_get cache => "$id/data";
627 }
628 }
629
630 my $t1 = Time::HiRes::time;
631 my $data = $process->(\@data);
632 my $t2 = Time::HiRes::time;
633
634 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
635
636 db_put cache => "$id/data", $data;
637 db_put cache => "$id/md5" , $md5;
638 db_put cache => "$id/meta", $meta;
639
640 return $data;
641 }
642
643 db_get cache => "$id/data"
378} 644}
379 645
380=item cf::datalog type => key => value, ... 646=item cf::datalog type => key => value, ...
381 647
382Log a datalog packet of the given type with the given key-value pairs. 648Log a datalog packet of the given type with the given key-value pairs.
400attach callbacks/event handlers (a collection of which is called an "attachment") 666attach callbacks/event handlers (a collection of which is called an "attachment")
401to it. All such attachable objects support the following methods. 667to it. All such attachable objects support the following methods.
402 668
403In the following description, CLASS can be any of C<global>, C<object> 669In the following description, CLASS can be any of C<global>, C<object>
404C<player>, C<client> or C<map> (i.e. the attachable objects in 670C<player>, C<client> or C<map> (i.e. the attachable objects in
405crossfire+). 671Crossfire TRT).
406 672
407=over 4 673=over 4
408 674
409=item $attachable->attach ($attachment, key => $value...) 675=item $attachable->attach ($attachment, key => $value...)
410 676
573 $registry = $CB_TYPE[$object_type] ||= []; 839 $registry = $CB_TYPE[$object_type] ||= [];
574 840
575 } elsif ($type eq "subtype") { 841 } elsif ($type eq "subtype") {
576 defined $object_type or Carp::croak "subtype specified without type"; 842 defined $object_type or Carp::croak "subtype specified without type";
577 my $object_subtype = shift @arg; 843 my $object_subtype = shift @arg;
578 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 844 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
579 845
580 } elsif ($type eq "package") { 846 } elsif ($type eq "package") {
581 my $pkg = shift @arg; 847 my $pkg = shift @arg;
582 848
583 while (my ($name, $id) = each %cb_id) { 849 while (my ($name, $id) = each %cb_id) {
612 _attach $registry, $klass, @attach; 878 _attach $registry, $klass, @attach;
613 } 879 }
614 880
615 $obj->{$name} = \%arg; 881 $obj->{$name} = \%arg;
616 } else { 882 } else {
617 warn "object uses attachment '$name' that is not available, postponing.\n"; 883 warn "object uses attachment '$name' which is not available, postponing.\n";
618 } 884 }
619 885
620 $obj->{_attachment}{$name} = undef; 886 $obj->{_attachment}{$name} = undef;
621} 887}
622 888
624 if (ref $_[0]) { 890 if (ref $_[0]) {
625 _object_attach @_; 891 _object_attach @_;
626 } else { 892 } else {
627 _attach shift->_attach_registry, @_; 893 _attach shift->_attach_registry, @_;
628 } 894 }
895 _recalc_want;
629}; 896};
630 897
631# all those should be optimised 898# all those should be optimised
632sub cf::attachable::detach { 899sub cf::attachable::detach {
633 my ($obj, $name) = @_; 900 my ($obj, $name) = @_;
636 delete $obj->{_attachment}{$name}; 903 delete $obj->{_attachment}{$name};
637 reattach ($obj); 904 reattach ($obj);
638 } else { 905 } else {
639 Carp::croak "cannot, currently, detach class attachments"; 906 Carp::croak "cannot, currently, detach class attachments";
640 } 907 }
908 _recalc_want;
641}; 909};
642 910
643sub cf::attachable::attached { 911sub cf::attachable::attached {
644 my ($obj, $name) = @_; 912 my ($obj, $name) = @_;
645 913
660 "; 928 ";
661 die if $@; 929 die if $@;
662} 930}
663 931
664our $override; 932our $override;
665our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 933our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
666 934
667sub override { 935sub override {
668 $override = 1; 936 $override = 1;
669 @invoke_results = (); 937 @INVOKE_RESULTS = (@_);
670} 938}
671 939
672sub do_invoke { 940sub do_invoke {
673 my $event = shift; 941 my $event = shift;
674 my $callbacks = shift; 942 my $callbacks = shift;
675 943
676 @invoke_results = (); 944 @INVOKE_RESULTS = ();
677 945
678 local $override; 946 local $override;
679 947
680 for (@$callbacks) { 948 for (@$callbacks) {
681 eval { &{$_->[1]} }; 949 eval { &{$_->[1]} };
698 966
699Generate an object-specific event with the given arguments. 967Generate an object-specific event with the given arguments.
700 968
701This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 969This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
702removed in future versions), and there is no public API to access override 970removed in future versions), and there is no public API to access override
703results (if you must, access C<@cf::invoke_results> directly). 971results (if you must, access C<@cf::INVOKE_RESULTS> directly).
704 972
705=back 973=back
706 974
707=cut 975=cut
708 976
709############################################################################# 977#############################################################################
710# object support 978# object support
979#
980
981sub _can_merge {
982 my ($ob1, $ob2) = @_;
983
984 local $Storable::canonical = 1;
985 my $fob1 = Storable::freeze $ob1;
986 my $fob2 = Storable::freeze $ob2;
987
988 $fob1 eq $fob2
989}
711 990
712sub reattach { 991sub reattach {
713 # basically do the same as instantiate, without calling instantiate 992 # basically do the same as instantiate, without calling instantiate
714 my ($obj) = @_; 993 my ($obj) = @_;
715 994
818 or return; 1097 or return;
819 $av = eval { (Storable::thaw $av)->{objs} }; 1098 $av = eval { (Storable::thaw $av)->{objs} };
820 } 1099 }
821 1100
822 warn sprintf "loading %s (%d)\n", 1101 warn sprintf "loading %s (%d)\n",
823 $filename, length $data, scalar @{$av || []};#d# 1102 $filename, length $data, scalar @{$av || []};
824 return ($data, $av); 1103 return ($data, $av);
825} 1104}
1105
1106=head2 COMMAND CALLBACKS
1107
1108=over 4
1109
1110=cut
826 1111
827############################################################################# 1112#############################################################################
828# command handling &c 1113# command handling &c
829 1114
830=item cf::register_command $name => \&callback($ob,$args); 1115=item cf::register_command $name => \&callback($ob,$args);
843 push @{ $COMMAND{$name} }, [$caller, $cb]; 1128 push @{ $COMMAND{$name} }, [$caller, $cb];
844} 1129}
845 1130
846=item cf::register_extcmd $name => \&callback($pl,$packet); 1131=item cf::register_extcmd $name => \&callback($pl,$packet);
847 1132
848Register a callbackf ro execution when the client sends an extcmd packet. 1133Register a callback for execution when the client sends an (synchronous)
1134extcmd packet. Ext commands will be processed in the order they are
1135received by the server, like other user commands. The first argument is
1136the logged-in player. Ext commands can only be processed after a player
1137has logged in successfully.
849 1138
850If the callback returns something, it is sent back as if reply was being 1139If the callback returns something, it is sent back as if reply was being
851called. 1140called.
852 1141
1142=item cf::register_exticmd $name => \&callback($ns,$packet);
1143
1144Register a callback for execution when the client sends an (asynchronous)
1145exticmd packet. Exti commands are processed by the server as soon as they
1146are received, i.e. out of order w.r.t. other commands. The first argument
1147is a client socket. Exti commands can be received anytime, even before
1148log-in.
1149
1150If the callback returns something, it is sent back as if reply was being
1151called.
1152
853=cut 1153=cut
854 1154
855sub register_extcmd { 1155sub register_extcmd {
856 my ($name, $cb) = @_; 1156 my ($name, $cb) = @_;
857 1157
858 $EXTCMD{$name} = $cb; 1158 $EXTCMD{$name} = $cb;
1159}
1160
1161sub register_exticmd {
1162 my ($name, $cb) = @_;
1163
1164 $EXTICMD{$name} = $cb;
859} 1165}
860 1166
861cf::player->attach ( 1167cf::player->attach (
862 on_command => sub { 1168 on_command => sub {
863 my ($pl, $name, $params) = @_; 1169 my ($pl, $name, $params) = @_;
872 cf::override; 1178 cf::override;
873 }, 1179 },
874 on_extcmd => sub { 1180 on_extcmd => sub {
875 my ($pl, $buf) = @_; 1181 my ($pl, $buf) = @_;
876 1182
877 my $msg = eval { from_json $buf }; 1183 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
878 1184
879 if (ref $msg) { 1185 if (ref $msg) {
1186 my ($type, $reply, @payload) =
1187 "ARRAY" eq ref $msg
1188 ? @$msg
1189 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1190
880 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1191 if (my $cb = $EXTCMD{$type}) {
881 if (my %reply = $cb->($pl, $msg)) { 1192 my @reply = $cb->($pl, @payload);
1193
882 $pl->ext_reply ($msg->{msgid}, %reply); 1194 $pl->ext_reply ($reply, @reply)
883 } 1195 if $reply;
884 } 1196 }
885 } else { 1197 } else {
886 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1198 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
887 } 1199 }
888 1200
889 cf::override; 1201 cf::override;
890 }, 1202 },
891); 1203);
892 1204
893sub load_extension {
894 my ($path) = @_;
895
896 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
897 my $base = $1;
898 my $pkg = $1;
899 $pkg =~ s/[^[:word:]]/_/g;
900 $pkg = "ext::$pkg";
901
902 warn "... loading '$path' into '$pkg'\n";
903
904 open my $fh, "<:utf8", $path
905 or die "$path: $!";
906
907 my $source =
908 "package $pkg; use strict; use utf8;\n"
909 . "#line 1 \"$path\"\n{\n"
910 . (do { local $/; <$fh> })
911 . "\n};\n1";
912
913 unless (eval $source) {
914 my $msg = $@ ? "$path: $@\n"
915 : "extension disabled.\n";
916 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
917 warn $@;
918 warn "mandatory extension failed to load, exiting.\n";
919 exit 1;
920 }
921 die $@;
922 }
923
924 push @EXTS, $pkg;
925}
926
927sub load_extensions { 1205sub load_extensions {
1206 cf::sync_job {
1207 my %todo;
1208
928 for my $ext (<$LIBDIR/*.ext>) { 1209 for my $path (<$LIBDIR/*.ext>) {
929 next unless -r $ext; 1210 next unless -r $path;
930 eval { 1211
931 load_extension $ext; 1212 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1213 my $base = $1;
1214 my $pkg = $1;
1215 $pkg =~ s/[^[:word:]]/_/g;
1216 $pkg = "ext::$pkg";
1217
1218 open my $fh, "<:utf8", $path
1219 or die "$path: $!";
1220
1221 my $source = do { local $/; <$fh> };
1222
1223 my %ext = (
1224 path => $path,
1225 base => $base,
1226 pkg => $pkg,
1227 );
1228
1229 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1230 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1231
1232 $ext{source} =
1233 "package $pkg; use strict; use utf8;\n"
1234 . "#line 1 \"$path\"\n{\n"
1235 . $source
1236 . "\n};\n1";
1237
1238 $todo{$base} = \%ext;
1239 }
1240
1241 my %done;
1242 while (%todo) {
1243 my $progress;
1244
1245 while (my ($k, $v) = each %todo) {
1246 for (split /,\s*/, $v->{meta}{depends}) {
1247 goto skip
1248 unless exists $done{$_};
1249 }
1250
1251 warn "... loading '$k' into '$v->{pkg}'\n";
1252
1253 unless (eval $v->{source}) {
1254 my $msg = $@ ? "$v->{path}: $@\n"
1255 : "$v->{base}: extension inactive.\n";
1256
1257 if (exists $v->{meta}{mandatory}) {
1258 warn $msg;
1259 warn "mandatory extension failed to load, exiting.\n";
1260 exit 1;
1261 }
1262
1263 warn $msg;
1264 }
1265
1266 $done{$k} = delete $todo{$k};
1267 push @EXTS, $v->{pkg};
1268 $progress = 1;
932 1 1269 }
933 } or warn "$ext not loaded: $@"; 1270
1271 skip:
1272 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1273 unless $progress;
1274 }
934 } 1275 };
935} 1276}
936 1277
937############################################################################# 1278#############################################################################
938 1279
1280=back
1281
939=head2 CORE EXTENSIONS 1282=head2 CORE EXTENSIONS
940 1283
941Functions and methods that extend core crossfire objects. 1284Functions and methods that extend core crossfire objects.
942 1285
943=cut 1286=cut
955Returns the given player object, loading it if necessary (might block). 1298Returns the given player object, loading it if necessary (might block).
956 1299
957=cut 1300=cut
958 1301
959sub playerdir($) { 1302sub playerdir($) {
960 cf::localdir 1303 "$PLAYERDIR/"
961 . "/"
962 . cf::playerdir
963 . "/"
964 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1304 . (ref $_[0] ? $_[0]->ob->name : $_[0])
965} 1305}
966 1306
967sub path($) { 1307sub path($) {
968 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1308 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1032 $cf::PLAYER{$login} = $self; 1372 $cf::PLAYER{$login} = $self;
1033 1373
1034 $self 1374 $self
1035} 1375}
1036 1376
1377=item $player->send_msg ($channel, $msg, $color, [extra...])
1378
1379=cut
1380
1381sub send_msg {
1382 my $ns = shift->ns
1383 or return;
1384 $ns->send_msg (@_);
1385}
1386
1037=item $pl->quit_character 1387=item $pl->quit_character
1038 1388
1039Nukes the player without looking back. If logged in, the connection will 1389Nukes the player without looking back. If logged in, the connection will
1040be destroyed. May block for a long time. 1390be destroyed. May block for a long time.
1041 1391
1088while and may block, so not sync_job-capable, ever. 1438while and may block, so not sync_job-capable, ever.
1089 1439
1090=cut 1440=cut
1091 1441
1092sub list_logins { 1442sub list_logins {
1093 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1443 my $dirs = aio_readdir $PLAYERDIR
1094 or return []; 1444 or return [];
1095 1445
1096 my @logins; 1446 my @logins;
1097 1447
1098 for my $login (@$dirs) { 1448 for my $login (@$dirs) {
1133 } 1483 }
1134 1484
1135 \@paths 1485 \@paths
1136} 1486}
1137 1487
1488=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1489
1490Expand crossfire pod fragments into protocol xml.
1491
1492=cut
1493
1494sub expand_cfpod {
1495 ((my $self), (local $_)) = @_;
1496
1497 # escape & and <
1498 s/&/&amp;/g;
1499 s/(?<![BIUGH])</&lt;/g;
1500
1501 # this is buggy, it needs to properly take care of nested <'s
1502
1503 1 while
1504 # replace B<>, I<>, U<> etc.
1505 s/B<([^\>]*)>/<b>$1<\/b>/
1506 || s/I<([^\>]*)>/<i>$1<\/i>/
1507 || s/U<([^\>]*)>/<u>$1<\/u>/
1508 # replace G<male|female> tags
1509 || s{G<([^>|]*)\|([^>]*)>}{
1510 $self->gender ? $2 : $1
1511 }ge
1512 # replace H<hint text>
1513 || s{H<([^\>]*)>}
1514 {
1515 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1516 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1517 "")
1518 [$self->{hintmode}]
1519 }ge;
1520
1521 # create single paragraphs (very hackish)
1522 s/(?<=\S)\n(?=\w)/ /g;
1523
1524 # compress some whitespace
1525 s/\s+\n/\n/g; # ws line-ends
1526 s/\n\n+/\n/g; # double lines
1527 s/^\n+//; # beginning lines
1528 s/\n+$//; # ending lines
1529
1530 $_
1531}
1532
1533sub hintmode {
1534 $_[0]{hintmode} = $_[1] if @_ > 1;
1535 $_[0]{hintmode}
1536}
1537
1138=item $player->ext_reply ($msgid, %msg) 1538=item $player->ext_reply ($msgid, @msg)
1139 1539
1140Sends an ext reply to the player. 1540Sends an ext reply to the player.
1141 1541
1142=cut 1542=cut
1143 1543
1144sub ext_reply($$%) { 1544sub ext_reply($$@) {
1145 my ($self, $id, %msg) = @_; 1545 my ($self, $id, @msg) = @_;
1146 1546
1147 $msg{msgid} = $id; 1547 if ($self->ns->extcmd == 2) {
1148 1548 $self->send ("ext " . $self->ns->{json_coder}->encode (["reply-$id", @msg]));
1149 $self->send ("ext " . cf::to_json \%msg); 1549 } elsif ($self->ns->extcmd == 1) {
1550 #TODO: version 1, remove
1551 unshift @msg, msgtype => "reply", msgid => $id;
1552 $self->send ("ext " . $self->ns->{json_coder}->encode ({@msg}));
1553 }
1150} 1554}
1151 1555
1152=item $player->ext_event ($type, %msg) 1556=item $player->ext_msg ($type, @msg)
1153 1557
1154Sends an ext event to the client. 1558Sends an ext event to the client.
1155 1559
1156=cut 1560=cut
1157 1561
1158sub ext_event($$%) { 1562sub ext_msg($$@) {
1159 my ($self, $type, %msg) = @_; 1563 my ($self, $type, @msg) = @_;
1160 1564
1161 $self->ns->ext_event ($type, %msg); 1565 $self->ns->ext_msg ($type, @msg);
1162} 1566}
1163 1567
1164package cf; 1568=head3 cf::region
1569
1570=over 4
1571
1572=cut
1573
1574package cf::region;
1575
1576=item cf::region::find_by_path $path
1577
1578Tries to decuce the likely region for a map knowing only its path.
1579
1580=cut
1581
1582sub find_by_path($) {
1583 my ($path) = @_;
1584
1585 my ($match, $specificity);
1586
1587 for my $region (list) {
1588 if ($region->{match} && $path =~ $region->{match}) {
1589 ($match, $specificity) = ($region, $region->specificity)
1590 if $region->specificity > $specificity;
1591 }
1592 }
1593
1594 $match
1595}
1165 1596
1166=back 1597=back
1167
1168 1598
1169=head3 cf::map 1599=head3 cf::map
1170 1600
1171=over 4 1601=over 4
1172 1602
1227 my ($self, $merge) = @_; 1657 my ($self, $merge) = @_;
1228 1658
1229 # we have to keep some variables in memory intact 1659 # we have to keep some variables in memory intact
1230 local $self->{path}; 1660 local $self->{path};
1231 local $self->{load_path}; 1661 local $self->{load_path};
1232 local $self->{deny_save};
1233 local $self->{deny_reset};
1234 1662
1235 $self->SUPER::thawer_merge ($merge); 1663 $self->SUPER::thawer_merge ($merge);
1236} 1664}
1237 1665
1238sub normalise { 1666sub normalise {
1285 $self->init; # pass $1 etc. 1713 $self->init; # pass $1 etc.
1286 return $self; 1714 return $self;
1287 } 1715 }
1288 } 1716 }
1289 1717
1290 Carp::carp "unable to resolve path '$path' (base '$base')."; 1718 Carp::cluck "unable to resolve path '$path' (base '$base').";
1291 () 1719 ()
1292} 1720}
1293 1721
1294sub init { 1722sub init {
1295 my ($self) = @_; 1723 my ($self) = @_;
1310 1738
1311# the original (read-only) location 1739# the original (read-only) location
1312sub load_path { 1740sub load_path {
1313 my ($self) = @_; 1741 my ($self) = @_;
1314 1742
1315 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path} 1743 "$MAPDIR/$self->{path}.map"
1316} 1744}
1317 1745
1318# the temporary/swap location 1746# the temporary/swap location
1319sub save_path { 1747sub save_path {
1320 my ($self) = @_; 1748 my ($self) = @_;
1321 1749
1322 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1750 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1323 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path 1751 "$TMPDIR/$path.map"
1324} 1752}
1325 1753
1326# the unique path, undef == no special unique path 1754# the unique path, undef == no special unique path
1327sub uniq_path { 1755sub uniq_path {
1328 my ($self) = @_; 1756 my ($self) = @_;
1329 1757
1330 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1758 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1331 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1759 "$UNIQUEDIR/$path"
1332} 1760}
1333 1761
1334# and all this just because we cannot iterate over 1762# and all this just because we cannot iterate over
1335# all maps in C++... 1763# all maps in C++...
1336sub change_all_map_light { 1764sub change_all_map_light {
1337 my ($change) = @_; 1765 my ($change) = @_;
1338 1766
1339 $_->change_map_light ($change) 1767 $_->change_map_light ($change)
1340 for grep $_->outdoor, values %cf::MAP; 1768 for grep $_->outdoor, values %cf::MAP;
1769}
1770
1771sub decay_objects {
1772 my ($self) = @_;
1773
1774 return if $self->{deny_reset};
1775
1776 $self->do_decay_objects;
1341} 1777}
1342 1778
1343sub unlink_save { 1779sub unlink_save {
1344 my ($self) = @_; 1780 my ($self) = @_;
1345 1781
1403 $self->load_header_orig 1839 $self->load_header_orig
1404 or return; 1840 or return;
1405 $self->prepare_orig; 1841 $self->prepare_orig;
1406 } 1842 }
1407 1843
1844 $self->{deny_reset} = 1
1845 if $self->no_reset;
1846
1847 $self->default_region (cf::region::find_by_path $self->{path})
1848 unless $self->default_region;
1849
1408 1 1850 1
1409} 1851}
1410 1852
1411sub find; 1853sub find;
1412sub find { 1854sub find {
1424 $map->{last_save} = $cf::RUNTIME; 1866 $map->{last_save} = $cf::RUNTIME;
1425 1867
1426 $map->load_header 1868 $map->load_header
1427 or return; 1869 or return;
1428 1870
1429 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1871 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1430 # doing this can freeze the server in a sync job, obviously 1872 # doing this can freeze the server in a sync job, obviously
1431 #$cf::WAIT_FOR_TICK->wait; 1873 #$cf::WAIT_FOR_TICK->wait;
1432 $map->reset; 1874 $map->reset;
1433 undef $guard; 1875 undef $guard;
1434 return find $path; 1876 return find $path;
1445 my ($self) = @_; 1887 my ($self) = @_;
1446 1888
1447 local $self->{deny_reset} = 1; # loading can take a long time 1889 local $self->{deny_reset} = 1; # loading can take a long time
1448 1890
1449 my $path = $self->{path}; 1891 my $path = $self->{path};
1892
1893 {
1450 my $guard = cf::lock_acquire "map_load:$path"; 1894 my $guard = cf::lock_acquire "map_load:$path";
1451 1895
1452 return if $self->in_memory != cf::MAP_SWAPPED; 1896 return if $self->in_memory != cf::MAP_SWAPPED;
1453 1897
1454 $self->in_memory (cf::MAP_LOADING); 1898 $self->in_memory (cf::MAP_LOADING);
1455 1899
1456 $self->alloc; 1900 $self->alloc;
1457 1901
1458 $self->pre_load; 1902 $self->pre_load;
1459
1460 $self->_load_objects ($self->{load_path}, 1)
1461 or return;
1462
1463 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1464 if delete $self->{load_original};
1465
1466 if (my $uniq = $self->uniq_path) {
1467 utf8::encode $uniq;
1468 if (aio_open $uniq, O_RDONLY, 0) {
1469 $self->clear_unique_items;
1470 $self->_load_objects ($uniq, 0);
1471 }
1472 }
1473
1474 Coro::cede;
1475
1476 # now do the right thing for maps
1477 $self->link_multipart_objects;
1478
1479 unless ($self->{deny_activate}) {
1480 $self->decay_objects;
1481 $self->fix_auto_apply;
1482 $self->update_buttons;
1483 Coro::cede; 1903 Coro::cede;
1484 $self->set_darkness_map; 1904
1905 $self->_load_objects ($self->{load_path}, 1)
1906 or return;
1907
1908 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1909 if delete $self->{load_original};
1910
1911 if (my $uniq = $self->uniq_path) {
1912 utf8::encode $uniq;
1913 if (aio_open $uniq, O_RDONLY, 0) {
1914 $self->clear_unique_items;
1915 $self->_load_objects ($uniq, 0);
1916 }
1917 }
1918
1919 Coro::cede;
1920 # now do the right thing for maps
1921 $self->link_multipart_objects;
1485 $self->difficulty ($self->estimate_difficulty) 1922 $self->difficulty ($self->estimate_difficulty)
1486 unless $self->difficulty; 1923 unless $self->difficulty;
1487 Coro::cede; 1924 Coro::cede;
1925
1926 unless ($self->{deny_activate}) {
1927 $self->decay_objects;
1928 $self->fix_auto_apply;
1929 $self->update_buttons;
1930 Coro::cede;
1931 $self->set_darkness_map;
1932 Coro::cede;
1488 $self->activate; 1933 $self->activate;
1934 }
1935
1936 $self->{last_save} = $cf::RUNTIME;
1937 $self->last_access ($cf::RUNTIME);
1938
1939 $self->in_memory (cf::MAP_IN_MEMORY);
1489 } 1940 }
1490 1941
1491 $self->post_load; 1942 $self->post_load;
1492
1493 $self->in_memory (cf::MAP_IN_MEMORY);
1494} 1943}
1495 1944
1496sub customise_for { 1945sub customise_for {
1497 my ($self, $ob) = @_; 1946 my ($self, $ob) = @_;
1498 1947
1499 return find "~" . $ob->name . "/" . $self->{path} 1948 return find "~" . $ob->name . "/" . $self->{path}
1500 if $self->per_player; 1949 if $self->per_player;
1950
1951# return find "?party/" . $ob->name . "/" . $self->{path}
1952# if $self->per_party;
1501 1953
1502 $self 1954 $self
1503} 1955}
1504 1956
1505# find and load all maps in the 3x3 area around a map 1957# find and load all maps in the 3x3 area around a map
1552 2004
1553 undef $MAP_PREFETCH{$path}; 2005 undef $MAP_PREFETCH{$path};
1554 $MAP_PREFETCHER ||= cf::async { 2006 $MAP_PREFETCHER ||= cf::async {
1555 while (%MAP_PREFETCH) { 2007 while (%MAP_PREFETCH) {
1556 for my $path (keys %MAP_PREFETCH) { 2008 for my $path (keys %MAP_PREFETCH) {
1557 my $map = find $path 2009 if (my $map = find $path) {
1558 or next;
1559 $map->load; 2010 $map->load;
2011 }
1560 2012
1561 delete $MAP_PREFETCH{$path}; 2013 delete $MAP_PREFETCH{$path};
1562 } 2014 }
1563 } 2015 }
1564 undef $MAP_PREFETCHER; 2016 undef $MAP_PREFETCHER;
1616 2068
1617sub reset_at { 2069sub reset_at {
1618 my ($self) = @_; 2070 my ($self) = @_;
1619 2071
1620 # TODO: safety, remove and allow resettable per-player maps 2072 # TODO: safety, remove and allow resettable per-player maps
1621 return 1e99 if $self->isa ("ext::map_per_player");#d#
1622 return 1e99 if $self->{deny_reset}; 2073 return 1e99 if $self->{deny_reset};
1623 2074
1624 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2075 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1625 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2076 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1626 2077
1637 my ($self) = @_; 2088 my ($self) = @_;
1638 2089
1639 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2090 my $lock = cf::lock_acquire "map_data:$self->{path}";
1640 2091
1641 return if $self->players; 2092 return if $self->players;
1642 return if $self->isa ("ext::map_per_player");#d#
1643 2093
1644 warn "resetting map ", $self->path;#d# 2094 warn "resetting map ", $self->path;
1645 2095
1646 $self->in_memory (cf::MAP_SWAPPED); 2096 $self->in_memory (cf::MAP_SWAPPED);
1647 2097
1648 # need to save uniques path 2098 # need to save uniques path
1649 unless ($self->{deny_save}) { 2099 unless ($self->{deny_save}) {
1681 $cf::MAP{$self->path} = $self; 2131 $cf::MAP{$self->path} = $self;
1682 2132
1683 $self->reset; # polite request, might not happen 2133 $self->reset; # polite request, might not happen
1684} 2134}
1685 2135
2136=item $maps = cf::map::tmp_maps
2137
2138Returns an arrayref with all map paths of currently instantiated and saved
2139maps. May block.
2140
2141=cut
2142
2143sub tmp_maps() {
2144 [
2145 map {
2146 utf8::decode $_;
2147 /\.map$/
2148 ? normalise $_
2149 : ()
2150 } @{ aio_readdir $TMPDIR or [] }
2151 ]
2152}
2153
2154=item $maps = cf::map::random_maps
2155
2156Returns an arrayref with all map paths of currently instantiated and saved
2157random maps. May block.
2158
2159=cut
2160
2161sub random_maps() {
2162 [
2163 map {
2164 utf8::decode $_;
2165 /\.map$/
2166 ? normalise "?random/$_"
2167 : ()
2168 } @{ aio_readdir $RANDOMDIR or [] }
2169 ]
2170}
2171
1686=item cf::map::unique_maps 2172=item cf::map::unique_maps
1687 2173
1688Returns an arrayref of paths of all shared maps that have 2174Returns an arrayref of paths of all shared maps that have
1689instantiated unique items. May block. 2175instantiated unique items. May block.
1690 2176
1691=cut 2177=cut
1692 2178
1693sub unique_maps() { 2179sub unique_maps() {
1694 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2180 [
1695 or return; 2181 map {
1696
1697 my @paths;
1698
1699 for (@$files) {
1700 utf8::decode $_; 2182 utf8::decode $_;
1701 next if /\.pst$/; 2183 /\.map$/
1702 next unless /^$PATH_SEP/o; 2184 ? normalise $_
1703 2185 : ()
1704 push @paths, cf::map::normalise $_; 2186 } @{ aio_readdir $UNIQUEDIR or [] }
1705 } 2187 ]
1706
1707 \@paths
1708} 2188}
1709 2189
1710package cf; 2190package cf;
1711 2191
1712=back 2192=back
1758 2238
1759 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2239 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1760 2240
1761 if ($self->{record_replies}) { 2241 if ($self->{record_replies}) {
1762 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2242 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2243
1763 } else { 2244 } else {
2245 my $pl = $self->contr;
2246
2247 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2248 my $dialog = $pl->{npc_dialog};
2249 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2250
2251 } else {
1764 $msg = $npc->name . " says: $msg" if $npc; 2252 $msg = $npc->name . " says: $msg" if $npc;
1765 $self->message ($msg, $flags); 2253 $self->message ($msg, $flags);
2254 }
1766 } 2255 }
2256}
2257
2258=item $object->send_msg ($channel, $msg, $color, [extra...])
2259
2260=cut
2261
2262sub cf::object::send_msg {
2263 my $pl = shift->contr
2264 or return;
2265 $pl->send_msg (@_);
1767} 2266}
1768 2267
1769=item $player_object->may ("access") 2268=item $player_object->may ("access")
1770 2269
1771Returns wether the given player is authorized to access resource "access" 2270Returns wether the given player is authorized to access resource "access"
1818 $self->deactivate_recursive; 2317 $self->deactivate_recursive;
1819 2318
1820 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2319 return if UNIVERSAL::isa $self->map, "ext::map_link";
1821 2320
1822 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2321 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1823 if $self->map; 2322 if $self->map && $self->map->{path} ne "{link}";
1824 2323
1825 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2324 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1826} 2325}
1827 2326
1828sub cf::object::player::leave_link { 2327sub cf::object::player::leave_link {
1829 my ($self, $map, $x, $y) = @_; 2328 my ($self, $map, $x, $y) = @_;
2329
2330 return unless $self->contr->active;
1830 2331
1831 my $link_pos = delete $self->{_link_pos}; 2332 my $link_pos = delete $self->{_link_pos};
1832 2333
1833 unless ($map) { 2334 unless ($map) {
1834 # restore original map position 2335 # restore original map position
1857 2358
1858 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2359 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1859 $self->enter_map ($map, $x, $y); 2360 $self->enter_map ($map, $x, $y);
1860} 2361}
1861 2362
1862cf::player->attach ( 2363=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1863 on_logout => sub {
1864 my ($pl) = @_;
1865 2364
1866 # abort map switching before logout 2365Moves the player to the given map-path and coordinates by first freezing
1867 if ($pl->ob->{_link_pos}) { 2366her, loading and preparing them map, calling the provided $check callback
1868 cf::sync_job { 2367that has to return the map if sucecssful, and then unfreezes the player on
1869 $pl->ob->leave_link 2368the new (success) or old (failed) map position. In either case, $done will
1870 }; 2369be called at the end of this process.
1871 }
1872 },
1873 on_login => sub {
1874 my ($pl) = @_;
1875 2370
1876 # try to abort aborted map switching on player login :)
1877 # should happen only on crashes
1878 if ($pl->ob->{_link_pos}) {
1879 $pl->ob->enter_link;
1880 (async {
1881 $pl->ob->reply (undef,
1882 "There was an internal problem at your last logout, "
1883 . "the server will try to bring you to your intended destination in a second.",
1884 cf::NDI_RED);
1885 # we need this sleep as the login has a concurrent enter_exit running
1886 # and this sleep increases chances of the player not ending up in scorn
1887 Coro::Timer::sleep 1;
1888 $pl->ob->leave_link;
1889 })->prio (2);
1890 }
1891 },
1892);
1893
1894=item $player_object->goto ($path, $x, $y)
1895
1896=cut 2371=cut
2372
2373our $GOTOGEN;
1897 2374
1898sub cf::object::player::goto { 2375sub cf::object::player::goto {
1899 my ($self, $path, $x, $y) = @_; 2376 my ($self, $path, $x, $y, $check, $done) = @_;
2377
2378 # do generation counting so two concurrent goto's will be executed in-order
2379 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1900 2380
1901 $self->enter_link; 2381 $self->enter_link;
1902 2382
1903 (async { 2383 (async {
1904 my $map = eval { 2384 my $map = eval {
1905 my $map = cf::map::find $path; 2385 my $map = cf::map::find $path;
2386
2387 if ($map) {
1906 $map = $map->customise_for ($self) if $map; 2388 $map = $map->customise_for ($self);
2389 $map = $check->($map) if $check && $map;
2390 } else {
2391 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2392 }
2393
1907 $map 2394 $map
2395 };
2396
2397 if ($@) {
2398 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2399 LOG llevError | logBacktrace, Carp::longmess $@;
1908 } or 2400 }
1909 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1910 2401
2402 if ($gen == $self->{_goto_generation}) {
2403 delete $self->{_goto_generation};
1911 $self->leave_link ($map, $x, $y); 2404 $self->leave_link ($map, $x, $y);
2405 }
2406
2407 $done->() if $done;
1912 })->prio (1); 2408 })->prio (1);
1913} 2409}
1914 2410
1915=item $player_object->enter_exit ($exit_object) 2411=item $player_object->enter_exit ($exit_object)
1916 2412
1955 2451
1956 $rmp->{random_seed} ||= $exit->random_seed; 2452 $rmp->{random_seed} ||= $exit->random_seed;
1957 2453
1958 my $data = cf::to_json $rmp; 2454 my $data = cf::to_json $rmp;
1959 my $md5 = Digest::MD5::md5_hex $data; 2455 my $md5 = Digest::MD5::md5_hex $data;
1960 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2456 my $meta = "$RANDOMDIR/$md5.meta";
1961 2457
1962 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2458 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1963 aio_write $fh, 0, (length $data), $data, 0; 2459 aio_write $fh, 0, (length $data), $data, 0;
1964 undef $fh; 2460 undef $fh;
1965 aio_rename "$meta~", $meta; 2461 aio_rename "$meta~", $meta;
1984 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2480 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1985 my $hp = $exit->stats->hp; 2481 my $hp = $exit->stats->hp;
1986 my $sp = $exit->stats->sp; 2482 my $sp = $exit->stats->sp;
1987 2483
1988 $self->enter_link; 2484 $self->enter_link;
2485
2486 # if exit is damned, update players death & WoR home-position
2487 $self->contr->savebed ($slaying, $hp, $sp)
2488 if $exit->flag (FLAG_DAMNED);
1989 2489
1990 (async { 2490 (async {
1991 $self->deactivate_recursive; # just to be sure 2491 $self->deactivate_recursive; # just to be sure
1992 unless (eval { 2492 unless (eval {
1993 $self->goto ($slaying, $hp, $sp); 2493 $self->goto ($slaying, $hp, $sp);
2021 2521
2022 utf8::encode $text; 2522 utf8::encode $text;
2023 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2523 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2024} 2524}
2025 2525
2526=item $client->send_msg ($channel, $msg, $color, [extra...])
2527
2528Send a drawinfo or msg packet to the client, formatting the msg for the
2529client if neccessary. C<$type> should be a string identifying the type of
2530the message, with C<log> being the default. If C<$color> is negative, suppress
2531the message unless the client supports the msg packet.
2532
2533=cut
2534
2535sub cf::client::send_msg {
2536 my ($self, $channel, $msg, $color, @extra) = @_;
2537
2538 $msg = $self->pl->expand_cfpod ($msg);
2539
2540 $color &= cf::NDI_CLIENT_MASK; # just in case...
2541
2542 if (ref $channel) {
2543 # send meta info to client, if not yet sent
2544 unless (exists $self->{channel}{$channel->{id}}) {
2545 $self->{channel}{$channel->{id}} = $channel;
2546 $self->ext_msg (channel_info => $channel);
2547 }
2548
2549 $channel = $channel->{id};
2550 }
2551
2552 return unless @extra || length $msg;
2553
2554 if ($self->can_msg) {
2555 # default colour, mask it out
2556 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2557 if $color & cf::NDI_DEF;
2558
2559 $self->send_packet ("msg " . $self->{json_coder}->encode (
2560 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2561 } else {
2562 if ($color >= 0) {
2563 # replace some tags by gcfclient-compatible ones
2564 for ($msg) {
2565 1 while
2566 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2567 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2568 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2569 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2570 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2571 }
2572
2573 $color &= cf::NDI_COLOR_MASK;
2574
2575 utf8::encode $msg;
2576
2577 if (0 && $msg =~ /\[/) {
2578 # COMMAND/INFO
2579 $self->send_packet ("drawextinfo $color 10 8 $msg")
2580 } else {
2581 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2582 $self->send_packet ("drawinfo $color $msg")
2583 }
2584 }
2585 }
2586}
2587
2026=item $client->ext_event ($type, %msg) 2588=item $client->ext_msg ($type, @msg)
2027 2589
2028Sends an exti event to the client. 2590Sends an ext event to the client.
2029 2591
2030=cut 2592=cut
2031 2593
2032sub cf::client::ext_event($$%) { 2594sub cf::client::ext_msg($$@) {
2033 my ($self, $type, %msg) = @_; 2595 my ($self, $type, @msg) = @_;
2034 2596
2597 my $extcmd = $self->extcmd;
2598
2599 if ($extcmd == 2) {
2600 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2601 } elsif ($extcmd == 1) { # TODO: remove
2035 $msg{msgtype} = "event_$type"; 2602 push @msg, msgtype => "event_$type";
2036 $self->send_packet ("ext " . cf::to_json \%msg); 2603 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2604 }
2037} 2605}
2038 2606
2039=item $success = $client->query ($flags, "text", \&cb) 2607=item $success = $client->query ($flags, "text", \&cb)
2040 2608
2041Queues a query to the client, calling the given callback with 2609Queues a query to the client, calling the given callback with
2042the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2610the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2043C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2611C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2044 2612
2045Queries can fail, so check the return code. Or don't, as queries will become 2613Queries can fail, so check the return code. Or don't, as queries will
2046reliable at some point in the future. 2614become reliable at some point in the future.
2047 2615
2048=cut 2616=cut
2049 2617
2050sub cf::client::query { 2618sub cf::client::query {
2051 my ($self, $flags, $text, $cb) = @_; 2619 my ($self, $flags, $text, $cb) = @_;
2059 utf8::encode $text; 2627 utf8::encode $text;
2060 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2628 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2061 2629
2062 $self->send_packet ($self->{query_queue}[0][0]) 2630 $self->send_packet ($self->{query_queue}[0][0])
2063 if @{ $self->{query_queue} } == 1; 2631 if @{ $self->{query_queue} } == 1;
2632
2633 1
2064} 2634}
2065 2635
2066cf::client->attach ( 2636cf::client->attach (
2637 on_connect => sub {
2638 my ($ns) = @_;
2639
2640 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2641 },
2067 on_reply => sub { 2642 on_reply => sub {
2068 my ($ns, $msg) = @_; 2643 my ($ns, $msg) = @_;
2069 2644
2070 # this weird shuffling is so that direct followup queries 2645 # this weird shuffling is so that direct followup queries
2071 # get handled first 2646 # get handled first
2083 } else { 2658 } else {
2084 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2659 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2085 } 2660 }
2086 } 2661 }
2087 }, 2662 },
2663 on_exticmd => sub {
2664 my ($ns, $buf) = @_;
2665
2666 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2667
2668 if (ref $msg) {
2669 my ($type, $reply, @payload) =
2670 "ARRAY" eq ref $msg
2671 ? @$msg
2672 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2673
2674 if (my $cb = $EXTICMD{$type}) {
2675 my @reply = $cb->($ns, @payload);
2676
2677 $ns->ext_reply ($reply, @reply)
2678 if $reply;
2679 }
2680 } else {
2681 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2682 }
2683
2684 cf::override;
2685 },
2088); 2686);
2089 2687
2090=item $client->async (\&cb) 2688=item $client->async (\&cb)
2091 2689
2092Create a new coroutine, running the specified callback. The coroutine will 2690Create a new coroutine, running the specified callback. The coroutine will
2133our $safe = new Safe "safe"; 2731our $safe = new Safe "safe";
2134our $safe_hole = new Safe::Hole; 2732our $safe_hole = new Safe::Hole;
2135 2733
2136$SIG{FPE} = 'IGNORE'; 2734$SIG{FPE} = 'IGNORE';
2137 2735
2138$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2736$safe->permit_only (Opcode::opset qw(
2737 :base_core :base_mem :base_orig :base_math
2738 grepstart grepwhile mapstart mapwhile
2739 sort time
2740));
2139 2741
2140# here we export the classes and methods available to script code 2742# here we export the classes and methods available to script code
2141 2743
2142=pod 2744=pod
2143 2745
2144The following functions and methods are available within a safe environment: 2746The following functions and methods are available within a safe environment:
2145 2747
2146 cf::object contr pay_amount pay_player map 2748 cf::object
2749 contr pay_amount pay_player map x y force_find force_add
2750 insert remove name archname title slaying race
2751
2147 cf::object::player player 2752 cf::object::player
2148 cf::player peaceful 2753 player
2149 cf::map trigger 2754
2755 cf::player
2756 peaceful
2757
2758 cf::map
2759 trigger
2150 2760
2151=cut 2761=cut
2152 2762
2153for ( 2763for (
2154 ["cf::object" => qw(contr pay_amount pay_player map)], 2764 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2765 insert remove inv name archname title slaying race)],
2155 ["cf::object::player" => qw(player)], 2766 ["cf::object::player" => qw(player)],
2156 ["cf::player" => qw(peaceful)], 2767 ["cf::player" => qw(peaceful)],
2157 ["cf::map" => qw(trigger)], 2768 ["cf::map" => qw(trigger)],
2158) { 2769) {
2159 no strict 'refs'; 2770 no strict 'refs';
2230=back 2841=back
2231 2842
2232=cut 2843=cut
2233 2844
2234############################################################################# 2845#############################################################################
2235
2236=head2 EXTENSION DATABASE SUPPORT
2237
2238Crossfire maintains a very simple database for extension use. It can
2239currently store anything that can be serialised using Storable, which
2240excludes objects.
2241
2242The parameter C<$family> should best start with the name of the extension
2243using it, it should be unique.
2244
2245=over 4
2246
2247=item $value = cf::db_get $family => $key
2248
2249Returns a single value from the database.
2250
2251=item cf::db_put $family => $key => $value
2252
2253Stores the given C<$value> in the family.
2254
2255=cut
2256
2257our $DB;
2258
2259sub db_init {
2260 unless ($DB) {
2261 $DB = BDB::db_create $DB_ENV;
2262
2263 cf::sync_job {
2264 eval {
2265 $DB->set_flags (BDB::CHKSUM);
2266
2267 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2268 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2269 cf::cleanup "db_open(db): $!" if $!;
2270 };
2271 cf::cleanup "db_open(db): $@" if $@;
2272 };
2273
2274 my $path = cf::localdir . "/database.pst";
2275 if (stat $path) {
2276 cf::sync_job {
2277 my $pst = Storable::retrieve $path;
2278
2279 cf::db_put (board => data => $pst->{board});
2280 cf::db_put (guildrules => data => $pst->{guildrules});
2281 cf::db_put (rent => balance => $pst->{rent}{balance});
2282 BDB::db_env_txn_checkpoint $DB_ENV;
2283
2284 unlink $path;
2285 };
2286 }
2287 }
2288}
2289
2290sub db_get($$) {
2291 my $key = "$_[0]/$_[1]";
2292
2293 cf::sync_job {
2294 BDB::db_get $DB, undef, $key, my $data;
2295
2296 $! ? ()
2297 : Compress::LZF::sthaw $data
2298 }
2299}
2300
2301sub db_put($$$) {
2302 BDB::dbreq_pri 4;
2303 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
2304}
2305
2306#############################################################################
2307# the server's init and main functions 2846# the server's init and main functions
2308 2847
2309sub load_facedata { 2848sub load_facedata($) {
2310 my $path = sprintf "%s/facedata", cf::datadir; 2849 my ($path) = @_;
2311 2850
2312 warn "loading facedata from $path\n"; 2851 warn "loading facedata from $path\n";
2313 2852
2314 my $facedata; 2853 my $facedata;
2315 0 < aio_load $path, $facedata 2854 0 < aio_load $path, $facedata
2323 { 2862 {
2324 my $faces = $facedata->{faceinfo}; 2863 my $faces = $facedata->{faceinfo};
2325 2864
2326 while (my ($face, $info) = each %$faces) { 2865 while (my ($face, $info) = each %$faces) {
2327 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2866 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2328 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2867 cf::face::set_visibility $idx, $info->{visibility};
2868 cf::face::set_magicmap $idx, $info->{magicmap};
2329 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2869 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2330 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2870 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2331 Coro::cede; 2871
2872 cf::cede_to_tick;
2332 } 2873 }
2333 2874
2334 while (my ($face, $info) = each %$faces) { 2875 while (my ($face, $info) = each %$faces) {
2335 next unless $info->{smooth}; 2876 next unless $info->{smooth};
2336 my $idx = cf::face::find $face 2877 my $idx = cf::face::find $face
2337 or next; 2878 or next;
2338 if (my $smooth = cf::face::find $info->{smooth}) { 2879 if (my $smooth = cf::face::find $info->{smooth}) {
2880 cf::face::set_smooth $idx, $smooth;
2339 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 2881 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2340 } else { 2882 } else {
2341 warn "smooth face '$info->{smooth}' not found for face '$face'"; 2883 warn "smooth face '$info->{smooth}' not found for face '$face'";
2342 } 2884 }
2343 Coro::cede; 2885
2886 cf::cede_to_tick;
2344 } 2887 }
2345 } 2888 }
2346 2889
2347 { 2890 {
2348 my $anims = $facedata->{animinfo}; 2891 my $anims = $facedata->{animinfo};
2349 2892
2350 while (my ($anim, $info) = each %$anims) { 2893 while (my ($anim, $info) = each %$anims) {
2351 cf::anim::set $anim, $info->{frames}, $info->{facings}; 2894 cf::anim::set $anim, $info->{frames}, $info->{facings};
2352 Coro::cede; 2895 cf::cede_to_tick;
2353 } 2896 }
2354 2897
2355 cf::anim::invalidate_all; # d'oh 2898 cf::anim::invalidate_all; # d'oh
2356 } 2899 }
2357 2900
2901 {
2902 # TODO: for gcfclient pleasure, we should give resources
2903 # that gcfclient doesn't grok a >10000 face index.
2904 my $res = $facedata->{resource};
2905 my $enc = JSON::XS->new->utf8->canonical;
2906
2907 my $soundconf = delete $res->{"res/sound.conf"};
2908
2909 while (my ($name, $info) = each %$res) {
2910 my $meta = $enc->encode ({
2911 name => $name,
2912 %{ $info->{meta} || {} },
2913 });
2914
2915 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2916
2917 if ($info->{type} & 1) {
2918 # prepend meta info
2919
2920 my $data = pack "(w/a*)*", $meta, $info->{data};
2921 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2922
2923 cf::face::set_data $idx, 0, $data, $chk;
2924 } else {
2925 cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};
2926 }
2927
2928 cf::face::set_type $idx, $info->{type};
2929
2930 cf::cede_to_tick;
2931 }
2932
2933 if ($soundconf) {
2934 $soundconf = $enc->decode (delete $soundconf->{data});
2935
2936 for (0 .. SOUND_CAST_SPELL_0 - 1) {
2937 my $sound = $soundconf->{compat}[$_]
2938 or next;
2939
2940 my $face = cf::face::find "sound/$sound->[1]";
2941 cf::sound::set $sound->[0] => $face;
2942 cf::sound::old_sound_index $_, $face; # gcfclient-compat
2943 }
2944
2945 while (my ($k, $v) = each %{$soundconf->{event}}) {
2946 my $face = cf::face::find "sound/$v";
2947 cf::sound::set $k => $face;
2948 }
2949 }
2950 }
2951
2358 1 2952 1
2359} 2953}
2360 2954
2955register_exticmd fx_want => sub {
2956 my ($ns, $want) = @_;
2957
2958 while (my ($k, $v) = each %$want) {
2959 $ns->fx_want ($k, $v);
2960 }
2961};
2962
2963sub reload_regions {
2964 load_resource_file "$MAPDIR/regions"
2965 or die "unable to load regions file\n";
2966
2967 for (cf::region::list) {
2968 $_->{match} = qr/$_->{match}/
2969 if exists $_->{match};
2970 }
2971}
2972
2973sub reload_facedata {
2974 load_facedata "$DATADIR/facedata"
2975 or die "unable to load facedata\n";
2976}
2977
2978sub reload_archetypes {
2979 load_resource_file "$DATADIR/archetypes"
2980 or die "unable to load archetypes\n";
2981 #d# NEED to laod twice to resolve forward references
2982 # this really needs to be done in an extra post-pass
2983 # (which needs to be synchronous, so solve it differently)
2984 load_resource_file "$DATADIR/archetypes"
2985 or die "unable to load archetypes\n";
2986}
2987
2988sub reload_treasures {
2989 load_resource_file "$DATADIR/treasures"
2990 or die "unable to load treasurelists\n";
2991}
2992
2361sub reload_resources { 2993sub reload_resources {
2362 load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir 2994 warn "reloading resource files...\n";
2363 or die "unable to load regions file\n";#d# 2995
2996 reload_regions;
2364 load_facedata 2997 reload_facedata;
2365 or die "unable to load facedata\n";#d# 2998 #reload_archetypes;#d#
2999 reload_archetypes;
3000 reload_treasures;
3001
3002 warn "finished reloading resource files\n";
2366} 3003}
2367 3004
2368sub init { 3005sub init {
2369 reload_resources; 3006 reload_resources;
2370} 3007}
2371 3008
2372sub cfg_load { 3009sub cfg_load {
2373 open my $fh, "<:utf8", cf::confdir . "/config" 3010 open my $fh, "<:utf8", "$CONFDIR/config"
2374 or return; 3011 or return;
2375 3012
2376 local $/; 3013 local $/;
2377 *CFG = YAML::Syck::Load <$fh>; 3014 *CFG = YAML::Syck::Load <$fh>;
2378 3015
2423 }, 3060 },
2424 ); 3061 );
2425 } 3062 }
2426} 3063}
2427 3064
3065sub write_runtime {
3066 my $runtime = "$LOCALDIR/runtime";
3067
3068 # first touch the runtime file to show we are still running:
3069 # the fsync below can take a very very long time.
3070
3071 IO::AIO::aio_utime $runtime, undef, undef;
3072
3073 my $guard = cf::lock_acquire "write_runtime";
3074
3075 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3076 or return;
3077
3078 my $value = $cf::RUNTIME + 90 + 10;
3079 # 10 is the runtime save interval, for a monotonic clock
3080 # 60 allows for the watchdog to kill the server.
3081
3082 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3083 and return;
3084
3085 # always fsync - this file is important
3086 aio_fsync $fh
3087 and return;
3088
3089 # touch it again to show we are up-to-date
3090 aio_utime $fh, undef, undef;
3091
3092 close $fh
3093 or return;
3094
3095 aio_rename "$runtime~", $runtime
3096 and return;
3097
3098 warn "runtime file written.\n";
3099
3100 1
3101}
3102
2428sub emergency_save() { 3103sub emergency_save() {
2429 my $freeze_guard = cf::freeze_mainloop; 3104 my $freeze_guard = cf::freeze_mainloop;
2430 3105
2431 warn "enter emergency perl save\n"; 3106 warn "enter emergency perl save\n";
2432 3107
2463 3138
2464 warn Carp::longmess "post_cleanup backtrace" 3139 warn Carp::longmess "post_cleanup backtrace"
2465 if $make_core; 3140 if $make_core;
2466} 3141}
2467 3142
2468sub reload() { 3143sub do_reload_perl() {
2469 # can/must only be called in main 3144 # can/must only be called in main
2470 if ($Coro::current != $Coro::main) { 3145 if ($Coro::current != $Coro::main) {
2471 warn "can only reload from main coroutine"; 3146 warn "can only reload from main coroutine";
2472 return; 3147 return;
2473 } 3148 }
2507 %EXT_CORO = (); 3182 %EXT_CORO = ();
2508 3183
2509 warn "removing commands"; 3184 warn "removing commands";
2510 %COMMAND = (); 3185 %COMMAND = ();
2511 3186
2512 warn "removing ext commands"; 3187 warn "removing ext/exti commands";
2513 %EXTCMD = (); 3188 %EXTCMD = ();
3189 %EXTICMD = ();
2514 3190
2515 warn "unloading/nuking all extensions"; 3191 warn "unloading/nuking all extensions";
2516 for my $pkg (@EXTS) { 3192 for my $pkg (@EXTS) {
2517 warn "... unloading $pkg"; 3193 warn "... unloading $pkg";
2518 3194
2548 Symbol::delete_package "safe::$_" 3224 Symbol::delete_package "safe::$_"
2549 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3225 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2550 3226
2551 warn "unloading cf.pm \"a bit\""; 3227 warn "unloading cf.pm \"a bit\"";
2552 delete $INC{"cf.pm"}; 3228 delete $INC{"cf.pm"};
3229 delete $INC{"cf/pod.pm"};
2553 3230
2554 # don't, removes xs symbols, too, 3231 # don't, removes xs symbols, too,
2555 # and global variables created in xs 3232 # and global variables created in xs
2556 #Symbol::delete_package __PACKAGE__; 3233 #Symbol::delete_package __PACKAGE__;
2557 3234
2572 warn "reattaching attachments to maps"; 3249 warn "reattaching attachments to maps";
2573 reattach $_ for values %MAP; 3250 reattach $_ for values %MAP;
2574 warn "reattaching attachments to players"; 3251 warn "reattaching attachments to players";
2575 reattach $_ for values %PLAYER; 3252 reattach $_ for values %PLAYER;
2576 3253
2577 warn "loading reloadable resources";
2578 reload_resources;
2579
2580 warn "leaving sync_job"; 3254 warn "leaving sync_job";
2581 3255
2582 1 3256 1
2583 } or do { 3257 } or do {
2584 warn $@; 3258 warn $@;
2589 warn "reloaded"; 3263 warn "reloaded";
2590}; 3264};
2591 3265
2592our $RELOAD_WATCHER; # used only during reload 3266our $RELOAD_WATCHER; # used only during reload
2593 3267
3268sub reload_perl() {
3269 # doing reload synchronously and two reloads happen back-to-back,
3270 # coro crashes during coro_state_free->destroy here.
3271
3272 $RELOAD_WATCHER ||= Event->timer (
3273 reentrant => 0,
3274 after => 0,
3275 data => WF_AUTOCANCEL,
3276 cb => sub {
3277 do_reload_perl;
3278 undef $RELOAD_WATCHER;
3279 },
3280 );
3281}
3282
2594register_command "reload" => sub { 3283register_command "reload" => sub {
2595 my ($who, $arg) = @_; 3284 my ($who, $arg) = @_;
2596 3285
2597 if ($who->flag (FLAG_WIZ)) { 3286 if ($who->flag (FLAG_WIZ)) {
2598 $who->message ("reloading server."); 3287 $who->message ("reloading server.");
2599 3288 async { reload_perl };
2600 # doing reload synchronously and two reloads happen back-to-back,
2601 # coro crashes during coro_state_free->destroy here.
2602
2603 $RELOAD_WATCHER ||= Event->timer (
2604 reentrant => 0,
2605 after => 0,
2606 data => WF_AUTOCANCEL,
2607 cb => sub {
2608 reload;
2609 undef $RELOAD_WATCHER;
2610 },
2611 );
2612 } 3289 }
2613}; 3290};
2614 3291
2615unshift @INC, $LIBDIR; 3292unshift @INC, $LIBDIR;
2616 3293
2617my $bug_warning = 0; 3294my $bug_warning = 0;
2618 3295
3296our @WAIT_FOR_TICK;
3297our @WAIT_FOR_TICK_BEGIN;
3298
3299sub wait_for_tick {
3300 return unless $TICK_WATCHER->is_active;
3301 return if $Coro::current == $Coro::main;
3302
3303 my $signal = new Coro::Signal;
3304 push @WAIT_FOR_TICK, $signal;
3305 $signal->wait;
3306}
3307
3308sub wait_for_tick_begin {
3309 return unless $TICK_WATCHER->is_active;
3310 return if $Coro::current == $Coro::main;
3311
3312 my $signal = new Coro::Signal;
3313 push @WAIT_FOR_TICK_BEGIN, $signal;
3314 $signal->wait;
3315}
3316
3317 my $min = 1e6;#d#
3318 my $avg = 10;
2619$TICK_WATCHER = Event->timer ( 3319$TICK_WATCHER = Event->timer (
2620 reentrant => 0, 3320 reentrant => 0,
2621 parked => 1, 3321 parked => 1,
2622 prio => 0, 3322 prio => 0,
2623 at => $NEXT_TICK || $TICK, 3323 at => $NEXT_TICK || $TICK,
2627 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3327 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2628 unless ++$bug_warning > 10; 3328 unless ++$bug_warning > 10;
2629 return; 3329 return;
2630 } 3330 }
2631 3331
2632 $NOW = Event::time; 3332 $NOW = $tick_start = Event::time;
2633 3333
2634 cf::server_tick; # one server iteration 3334 cf::server_tick; # one server iteration
3335
3336 0 && sync_job {#d#
3337 for(1..10) {
3338 my $t = Event::time;
3339 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3340 or die;
3341
3342 $map->width (50);
3343 $map->height (50);
3344 $map->alloc;
3345 $map->_load_objects ("/tmp/x.map", 1);
3346 my $t = Event::time - $t;
3347
3348 #next unless $t < 0.0013;#d#
3349 if ($t < $min) {
3350 $min = $t;
3351 }
3352 $avg = $avg * 0.99 + $t * 0.01;
3353 }
3354 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3355 exit 0;
3356 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3357 };
3358
2635 $RUNTIME += $TICK; 3359 $RUNTIME += $TICK;
2636 $NEXT_TICK += $TICK; 3360 $NEXT_TICK += $TICK;
2637 3361
2638 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3362 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2639 $NEXT_RUNTIME_WRITE = $NOW + 10; 3363 $NEXT_RUNTIME_WRITE = $NOW + 10;
2641 write_runtime 3365 write_runtime
2642 or warn "ERROR: unable to write runtime file: $!"; 3366 or warn "ERROR: unable to write runtime file: $!";
2643 }; 3367 };
2644 } 3368 }
2645 3369
2646 $WAIT_FOR_TICK->broadcast;
2647 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2648
2649# my $AFTER = Event::time; 3370# my $AFTER = Event::time;
2650# warn $AFTER - $NOW;#d# 3371# warn $AFTER - $NOW;#d#
2651 3372
3373 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3374 $sig->send;
3375 }
3376 while (my $sig = shift @WAIT_FOR_TICK) {
3377 $sig->send;
3378 }
3379
3380 $NOW = Event::time;
3381
2652 # if we are delayed by four ticks or more, skip them all 3382 # if we are delayed by four ticks or more, skip them all
2653 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3383 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2654 3384
2655 $TICK_WATCHER->at ($NEXT_TICK); 3385 $TICK_WATCHER->at ($NEXT_TICK);
2656 $TICK_WATCHER->start; 3386 $TICK_WATCHER->start;
3387
3388 $LOAD = ($NOW - $tick_start) / $TICK;
3389 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3390
3391 _post_tick;
3392
3393
2657 }, 3394 },
2658); 3395);
2659 3396
2660{ 3397{
2661 BDB::max_poll_time $TICK * 0.1; 3398 BDB::max_poll_time $TICK * 0.1;
2689 3426
2690 cf::sync_job { 3427 cf::sync_job {
2691 eval { 3428 eval {
2692 BDB::db_env_open 3429 BDB::db_env_open
2693 $DB_ENV, 3430 $DB_ENV,
2694 $BDB_ENV_DIR, 3431 $BDBDIR,
2695 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3432 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2696 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3433 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2697 0666; 3434 0666;
2698 3435
2699 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!; 3436 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2700 3437
2701 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1); 3438 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2702 $DB_ENV->set_lk_detect; 3439 $DB_ENV->set_lk_detect;
2703 }; 3440 };
2704 3441
2720 prio => 6, 3457 prio => 6,
2721 cb => \&IO::AIO::poll_cb, 3458 cb => \&IO::AIO::poll_cb,
2722 ); 3459 );
2723} 3460}
2724 3461
3462my $_log_backtrace;
3463
3464sub _log_backtrace {
3465 my ($msg, @addr) = @_;
3466
3467 $msg =~ s/\n//;
3468
3469 # limit the # of concurrent backtraces
3470 if ($_log_backtrace < 2) {
3471 ++$_log_backtrace;
3472 async {
3473 my @bt = fork_call {
3474 @addr = map { sprintf "%x", $_ } @addr;
3475 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3476 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3477 or die "addr2line: $!";
3478
3479 my @funcs;
3480 my @res = <$fh>;
3481 chomp for @res;
3482 while (@res) {
3483 my ($func, $line) = splice @res, 0, 2, ();
3484 push @funcs, "[$func] $line";
3485 }
3486
3487 @funcs
3488 };
3489
3490 LOG llevInfo, "[ABT] $msg\n";
3491 LOG llevInfo, "[ABT] $_\n" for @bt;
3492 --$_log_backtrace;
3493 };
3494 } else {
3495 LOG llevInfo, "[ABT] $msg\n";
3496 LOG llevInfo, "[ABT] [suppressed]\n";
3497 }
3498}
3499
3500# load additional modules
3501use cf::pod;
3502
2725END { cf::emergency_save } 3503END { cf::emergency_save }
2726 3504
27271 35051
2728 3506

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines