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

Diff Legend

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