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.96 by root, Fri Dec 22 06:02:29 2006 UTC vs.
Revision 1.342 by root, Sun Aug 26 15:31:02 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
1154 my @reply;
1155
613 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1156 if (my $cb = $EXTCMD{$type}) {
614 if (my %reply = $cb->[0]->($pl, $msg)) { 1157 @reply = $cb->($pl, @payload);
615 $pl->ext_reply ($msg->{msgid}, %reply);
616 }
617 } 1158 }
1159
1160 $pl->ext_reply ($reply, @reply)
1161 if $reply;
1162
618 } else { 1163 } else {
619 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1164 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
620 } 1165 }
621 1166
622 cf::override; 1167 cf::override;
623 }, 1168 },
624); 1169);
625 1170
1171sub load_extensions {
1172 cf::sync_job {
1173 my %todo;
1174
1175 for my $path (<$LIBDIR/*.ext>) {
1176 next unless -r $path;
1177
1178 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1179 my $base = $1;
1180 my $pkg = $1;
1181 $pkg =~ s/[^[:word:]]/_/g;
1182 $pkg = "ext::$pkg";
1183
1184 open my $fh, "<:utf8", $path
1185 or die "$path: $!";
1186
1187 my $source = do { local $/; <$fh> };
1188
1189 my %ext = (
1190 path => $path,
1191 base => $base,
1192 pkg => $pkg,
1193 );
1194
1195 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1196 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1197
1198 $ext{source} =
1199 "package $pkg; use strict; use utf8;\n"
1200 . "#line 1 \"$path\"\n{\n"
1201 . $source
1202 . "\n};\n1";
1203
1204 $todo{$base} = \%ext;
1205 }
1206
1207 my %done;
1208 while (%todo) {
1209 my $progress;
1210
1211 while (my ($k, $v) = each %todo) {
1212 for (split /,\s*/, $v->{meta}{depends}) {
1213 goto skip
1214 unless exists $done{$_};
1215 }
1216
1217 warn "... loading '$k' into '$v->{pkg}'\n";
1218
1219 unless (eval $v->{source}) {
1220 my $msg = $@ ? "$v->{path}: $@\n"
1221 : "$v->{base}: extension inactive.\n";
1222
1223 if (exists $v->{meta}{mandatory}) {
1224 warn $msg;
1225 warn "mandatory extension failed to load, exiting.\n";
1226 exit 1;
1227 }
1228
1229 warn $msg;
1230 }
1231
1232 $done{$k} = delete $todo{$k};
1233 push @EXTS, $v->{pkg};
1234 $progress = 1;
1235 }
1236
1237 skip:
1238 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1239 unless $progress;
1240 }
1241 };
1242}
1243
1244#############################################################################
1245
1246=back
1247
1248=head2 CORE EXTENSIONS
1249
1250Functions and methods that extend core crossfire objects.
1251
1252=cut
1253
1254package cf::player;
1255
1256use Coro::AIO;
1257
1258=head3 cf::player
1259
1260=over 4
1261
1262=item cf::player::find $login
1263
1264Returns the given player object, loading it if necessary (might block).
1265
1266=cut
1267
1268sub playerdir($) {
1269 "$PLAYERDIR/"
1270 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1271}
1272
1273sub path($) {
1274 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1275
1276 (playerdir $login) . "/playerdata"
1277}
1278
1279sub find_active($) {
1280 $cf::PLAYER{$_[0]}
1281 and $cf::PLAYER{$_[0]}->active
1282 and $cf::PLAYER{$_[0]}
1283}
1284
1285sub exists($) {
1286 my ($login) = @_;
1287
1288 $cf::PLAYER{$login}
1289 or cf::sync_job { !aio_stat path $login }
1290}
1291
1292sub find($) {
1293 return $cf::PLAYER{$_[0]} || do {
1294 my $login = $_[0];
1295
1296 my $guard = cf::lock_acquire "user_find:$login";
1297
1298 $cf::PLAYER{$_[0]} || do {
1299 # rename old playerfiles to new ones
1300 #TODO: remove when no longer required
1301 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1302 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1303 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1304 aio_unlink +(playerdir $login) . "/$login.pl";
1305
1306 my $pl = load_pl path $login
1307 or return;
1308 $cf::PLAYER{$login} = $pl
1309 }
1310 }
1311}
1312
1313sub save($) {
1314 my ($pl) = @_;
1315
1316 return if $pl->{deny_save};
1317
1318 my $path = path $pl;
1319 my $guard = cf::lock_acquire "user_save:$path";
1320
1321 return if $pl->{deny_save};
1322
1323 aio_mkdir playerdir $pl, 0770;
1324 $pl->{last_save} = $cf::RUNTIME;
1325
1326 $pl->save_pl ($path);
1327 Coro::cede;
1328}
1329
1330sub new($) {
1331 my ($login) = @_;
1332
1333 my $self = create;
1334
1335 $self->ob->name ($login);
1336 $self->{deny_save} = 1;
1337
1338 $cf::PLAYER{$login} = $self;
1339
1340 $self
1341}
1342
1343=item $player->send_msg ($channel, $msg, $color, [extra...])
1344
1345=cut
1346
1347sub send_msg {
1348 my $ns = shift->ns
1349 or return;
1350 $ns->send_msg (@_);
1351}
1352
1353=item $pl->quit_character
1354
1355Nukes the player without looking back. If logged in, the connection will
1356be destroyed. May block for a long time.
1357
1358=cut
1359
1360sub quit_character {
1361 my ($pl) = @_;
1362
1363 my $name = $pl->ob->name;
1364
1365 $pl->{deny_save} = 1;
1366 $pl->password ("*"); # this should lock out the player until we nuked the dir
1367
1368 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1369 $pl->deactivate;
1370 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1371 $pl->ns->destroy if $pl->ns;
1372
1373 my $path = playerdir $pl;
1374 my $temp = "$path~$cf::RUNTIME~deleting~";
1375 aio_rename $path, $temp;
1376 delete $cf::PLAYER{$pl->ob->name};
1377 $pl->destroy;
1378
1379 my $prefix = qr<^~\Q$name\E/>;
1380
1381 # nuke player maps
1382 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1383
1384 IO::AIO::aio_rmtree $temp;
1385}
1386
1387=item $pl->kick
1388
1389Kicks a player out of the game. This destroys the connection.
1390
1391=cut
1392
1393sub kick {
1394 my ($pl, $kicker) = @_;
1395
1396 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1397 $pl->killer ("kicked");
1398 $pl->ns->destroy;
1399}
1400
1401=item cf::player::list_logins
1402
1403Returns am arrayref of all valid playernames in the system, can take a
1404while and may block, so not sync_job-capable, ever.
1405
1406=cut
1407
1408sub list_logins {
1409 my $dirs = aio_readdir $PLAYERDIR
1410 or return [];
1411
1412 my @logins;
1413
1414 for my $login (@$dirs) {
1415 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1416 aio_read $fh, 0, 512, my $buf, 0 or next;
1417 $buf !~ /^password -------------$/m or next; # official not-valid tag
1418
1419 utf8::decode $login;
1420 push @logins, $login;
1421 }
1422
1423 \@logins
1424}
1425
1426=item $player->maps
1427
1428Returns an arrayref of map paths that are private for this
1429player. May block.
1430
1431=cut
1432
1433sub maps($) {
1434 my ($pl) = @_;
1435
1436 $pl = ref $pl ? $pl->ob->name : $pl;
1437
1438 my $files = aio_readdir playerdir $pl
1439 or return;
1440
1441 my @paths;
1442
1443 for (@$files) {
1444 utf8::decode $_;
1445 next if /\.(?:pl|pst)$/;
1446 next unless /^$PATH_SEP/o;
1447
1448 push @paths, cf::map::normalise "~$pl/$_";
1449 }
1450
1451 \@paths
1452}
1453
1454=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1455
1456Expand crossfire pod fragments into protocol xml.
1457
1458=cut
1459
1460sub expand_cfpod {
1461 ((my $self), (local $_)) = @_;
1462
1463 # escape & and <
1464 s/&/&amp;/g;
1465 s/(?<![BIUGH])</&lt;/g;
1466
1467 # this is buggy, it needs to properly take care of nested <'s
1468
1469 1 while
1470 # replace B<>, I<>, U<> etc.
1471 s/B<([^\>]*)>/<b>$1<\/b>/
1472 || s/I<([^\>]*)>/<i>$1<\/i>/
1473 || s/U<([^\>]*)>/<u>$1<\/u>/
1474 # replace G<male|female> tags
1475 || s{G<([^>|]*)\|([^>]*)>}{
1476 $self->gender ? $2 : $1
1477 }ge
1478 # replace H<hint text>
1479 || s{H<([^\>]*)>}
1480 {
1481 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1482 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1483 "")
1484 [$self->{hintmode}]
1485 }ge;
1486
1487 # create single paragraphs (very hackish)
1488 s/(?<=\S)\n(?=\w)/ /g;
1489
1490 # compress some whitespace
1491 s/\s+\n/\n/g; # ws line-ends
1492 s/\n\n+/\n/g; # double lines
1493 s/^\n+//; # beginning lines
1494 s/\n+$//; # ending lines
1495
1496 $_
1497}
1498
1499sub hintmode {
1500 $_[0]{hintmode} = $_[1] if @_ > 1;
1501 $_[0]{hintmode}
1502}
1503
1504=item $player->ext_reply ($msgid, @msg)
1505
1506Sends an ext reply to the player.
1507
1508=cut
1509
1510sub ext_reply($$@) {
1511 my ($self, $id, @msg) = @_;
1512
1513 $self->ns->ext_reply ($id, @msg)
1514}
1515
1516=item $player->ext_msg ($type, @msg)
1517
1518Sends an ext event to the client.
1519
1520=cut
1521
1522sub ext_msg($$@) {
1523 my ($self, $type, @msg) = @_;
1524
1525 $self->ns->ext_msg ($type, @msg);
1526}
1527
1528=head3 cf::region
1529
1530=over 4
1531
1532=cut
1533
1534package cf::region;
1535
1536=item cf::region::find_by_path $path
1537
1538Tries to decuce the likely region for a map knowing only its path.
1539
1540=cut
1541
1542sub find_by_path($) {
1543 my ($path) = @_;
1544
1545 my ($match, $specificity);
1546
1547 for my $region (list) {
1548 if ($region->{match} && $path =~ $region->{match}) {
1549 ($match, $specificity) = ($region, $region->specificity)
1550 if $region->specificity > $specificity;
1551 }
1552 }
1553
1554 $match
1555}
1556
1557=back
1558
1559=head3 cf::map
1560
1561=over 4
1562
1563=cut
1564
1565package cf::map;
1566
1567use Fcntl;
1568use Coro::AIO;
1569
1570use overload
1571 '""' => \&as_string,
1572 fallback => 1;
1573
1574our $MAX_RESET = 3600;
1575our $DEFAULT_RESET = 3000;
1576
1577sub generate_random_map {
1578 my ($self, $rmp) = @_;
1579 # mit "rum" bekleckern, nicht
1580 $self->_create_random_map (
1581 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1582 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1583 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1584 $rmp->{exit_on_final_map},
1585 $rmp->{xsize}, $rmp->{ysize},
1586 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1587 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1588 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1589 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1590 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1591 (cf::region::find $rmp->{region}), $rmp->{custom}
1592 )
1593}
1594
1595=item cf::map->register ($regex, $prio)
1596
1597Register a handler for the map path matching the given regex at the
1598givne priority (higher is better, built-in handlers have priority 0, the
1599default).
1600
1601=cut
1602
626sub register { 1603sub register {
1604 my (undef, $regex, $prio) = @_;
1605 my $pkg = caller;
1606
1607 no strict;
1608 push @{"$pkg\::ISA"}, __PACKAGE__;
1609
1610 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1611}
1612
1613# also paths starting with '/'
1614$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1615
1616sub thawer_merge {
627 my ($base, $pkg) = @_; 1617 my ($self, $merge) = @_;
628 1618
629 #TODO 1619 # we have to keep some variables in memory intact
630} 1620 local $self->{path};
1621 local $self->{load_path};
631 1622
632sub load_extension { 1623 $self->SUPER::thawer_merge ($merge);
1624}
1625
1626sub normalise {
633 my ($path) = @_; 1627 my ($path, $base) = @_;
634 1628
635 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1629 $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 1630
641 warn "loading '$path' into '$pkg'\n"; 1631 $path =~ s/\.map$//;
642 1632
643 open my $fh, "<:utf8", $path 1633 # map plan:
644 or die "$path: $!"; 1634 #
1635 # /! non-realised random map exit (special hack!)
1636 # {... are special paths that are not being touched
1637 # ?xxx/... are special absolute paths
1638 # ?random/... random maps
1639 # /... normal maps
1640 # ~user/... per-player map of a specific user
645 1641
646 my $source = 1642 $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 1643
652 eval $source 1644 # treat it as relative path if it starts with
653 or die $@ ? "$path: $@\n" 1645 # something that looks reasonable
654 : "extension disabled.\n"; 1646 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1647 $base or Carp::carp "normalise called with relative path and no base: '$path'";
655 1648
656 push @exts, $pkg; 1649 $base =~ s{[^/]+/?$}{};
657 $ext_pkg{$base} = $pkg; 1650 $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# } 1651 }
675 1652
676 # remove commands 1653 for ($path) {
677 for my $name (keys %COMMAND) { 1654 redo if s{//}{/};
678 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} }; 1655 redo if s{/\.?/}{/};
1656 redo if s{/[^/]+/\.\./}{/};
1657 }
679 1658
680 if (@cb) { 1659 $path
681 $COMMAND{$name} = \@cb; 1660}
1661
1662sub new_from_path {
1663 my (undef, $path, $base) = @_;
1664
1665 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1666
1667 $path = normalise $path, $base;
1668
1669 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1670 if ($path =~ $EXT_MAP{$pkg}[1]) {
1671 my $self = bless cf::map::new, $pkg;
1672 $self->{path} = $path; $self->path ($path);
1673 $self->init; # pass $1 etc.
1674 return $self;
1675 }
1676 }
1677
1678 Carp::cluck "unable to resolve path '$path' (base '$base').";
1679 ()
1680}
1681
1682sub init {
1683 my ($self) = @_;
1684
1685 $self
1686}
1687
1688sub as_string {
1689 my ($self) = @_;
1690
1691 "$self->{path}"
1692}
1693
1694# the displayed name, this is a one way mapping
1695sub visible_name {
1696 &as_string
1697}
1698
1699# the original (read-only) location
1700sub load_path {
1701 my ($self) = @_;
1702
1703 "$MAPDIR/$self->{path}.map"
1704}
1705
1706# the temporary/swap location
1707sub save_path {
1708 my ($self) = @_;
1709
1710 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1711 "$TMPDIR/$path.map"
1712}
1713
1714# the unique path, undef == no special unique path
1715sub uniq_path {
1716 my ($self) = @_;
1717
1718 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1719 "$UNIQUEDIR/$path"
1720}
1721
1722# and all this just because we cannot iterate over
1723# all maps in C++...
1724sub change_all_map_light {
1725 my ($change) = @_;
1726
1727 $_->change_map_light ($change)
1728 for grep $_->outdoor, values %cf::MAP;
1729}
1730
1731sub decay_objects {
1732 my ($self) = @_;
1733
1734 return if $self->{deny_reset};
1735
1736 $self->do_decay_objects;
1737}
1738
1739sub unlink_save {
1740 my ($self) = @_;
1741
1742 utf8::encode (my $save = $self->save_path);
1743 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1744 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1745}
1746
1747sub load_header_from($) {
1748 my ($self, $path) = @_;
1749
1750 utf8::encode $path;
1751 #aio_open $path, O_RDONLY, 0
1752 # or return;
1753
1754 $self->_load_header ($path)
1755 or return;
1756
1757 $self->{load_path} = $path;
1758
1759 1
1760}
1761
1762sub load_header_orig {
1763 my ($self) = @_;
1764
1765 $self->load_header_from ($self->load_path)
1766}
1767
1768sub load_header_temp {
1769 my ($self) = @_;
1770
1771 $self->load_header_from ($self->save_path)
1772}
1773
1774sub prepare_temp {
1775 my ($self) = @_;
1776
1777 $self->last_access ((delete $self->{last_access})
1778 || $cf::RUNTIME); #d#
1779 # safety
1780 $self->{instantiate_time} = $cf::RUNTIME
1781 if $self->{instantiate_time} > $cf::RUNTIME;
1782}
1783
1784sub prepare_orig {
1785 my ($self) = @_;
1786
1787 $self->{load_original} = 1;
1788 $self->{instantiate_time} = $cf::RUNTIME;
1789 $self->last_access ($cf::RUNTIME);
1790 $self->instantiate;
1791}
1792
1793sub load_header {
1794 my ($self) = @_;
1795
1796 if ($self->load_header_temp) {
1797 $self->prepare_temp;
682 } else { 1798 } else {
683 delete $COMMAND{$name}; 1799 $self->load_header_orig
684 } 1800 or return;
1801 $self->prepare_orig;
1802 }
1803
1804 $self->{deny_reset} = 1
1805 if $self->no_reset;
1806
1807 $self->default_region (cf::region::find_by_path $self->{path})
1808 unless $self->default_region;
1809
685 } 1810 1
1811}
686 1812
687 # remove extcmds 1813sub find;
688 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) { 1814sub find {
689 delete $EXTCMD{$name}; 1815 my ($path, $origin) = @_;
1816
1817 $path = normalise $path, $origin && $origin->path;
1818
1819 cf::lock_wait "map_find:$path";
1820
1821 $cf::MAP{$path} || do {
1822 my $guard = cf::lock_acquire "map_find:$path";
1823 my $map = new_from_path cf::map $path
1824 or return;
1825
1826 $map->{last_save} = $cf::RUNTIME;
1827
1828 $map->load_header
1829 or return;
1830
1831 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1832 # doing this can freeze the server in a sync job, obviously
1833 #$cf::WAIT_FOR_TICK->wait;
1834 $map->reset;
1835 undef $guard;
1836 return find $path;
1837 }
1838
1839 $cf::MAP{$path} = $map
1840 }
1841}
1842
1843sub pre_load { }
1844sub post_load { }
1845
1846sub load {
1847 my ($self) = @_;
1848
1849 local $self->{deny_reset} = 1; # loading can take a long time
1850
1851 my $path = $self->{path};
1852
690 } 1853 {
1854 my $guard = cf::lock_acquire "map_load:$path";
691 1855
692 if (my $cb = $pkg->can ("unload")) { 1856 return if $self->in_memory != cf::MAP_SWAPPED;
693 eval { 1857
694 $cb->($pkg); 1858 $self->in_memory (cf::MAP_LOADING);
1859
1860 $self->alloc;
1861
1862 $self->pre_load;
1863 Coro::cede;
1864
1865 $self->_load_objects ($self->{load_path}, 1)
1866 or return;
1867
1868 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1869 if delete $self->{load_original};
1870
1871 if (my $uniq = $self->uniq_path) {
1872 utf8::encode $uniq;
1873 if (aio_open $uniq, O_RDONLY, 0) {
1874 $self->clear_unique_items;
1875 $self->_load_objects ($uniq, 0);
695 1 1876 }
696 } or warn "$pkg unloaded, but with errors: $@"; 1877 }
697 }
698 1878
699 Symbol::delete_package $pkg; 1879 Coro::cede;
700} 1880 # now do the right thing for maps
1881 $self->link_multipart_objects;
1882 $self->difficulty ($self->estimate_difficulty)
1883 unless $self->difficulty;
1884 Coro::cede;
701 1885
702sub load_extensions { 1886 unless ($self->{deny_activate}) {
703 for my $ext (<$LIBDIR/*.ext>) { 1887 $self->decay_objects;
704 next unless -r $ext; 1888 $self->fix_auto_apply;
705 eval { 1889 $self->update_buttons;
706 load_extension $ext; 1890 Coro::cede;
707 1 1891 $self->set_darkness_map;
708 } or warn "$ext not loaded: $@"; 1892 Coro::cede;
709 } 1893 $self->activate;
710} 1894 }
711 1895
712############################################################################# 1896 $self->{last_save} = $cf::RUNTIME;
713# load/save/clean perl data associated with a map 1897 $self->last_access ($cf::RUNTIME);
714 1898
715*cf::mapsupport::on_clean = sub { 1899 $self->in_memory (cf::MAP_IN_MEMORY);
1900 }
1901
1902 $self->post_load;
1903}
1904
1905sub customise_for {
1906 my ($self, $ob) = @_;
1907
1908 return find "~" . $ob->name . "/" . $self->{path}
1909 if $self->per_player;
1910
1911# return find "?party/" . $ob->name . "/" . $self->{path}
1912# if $self->per_party;
1913
1914 $self
1915}
1916
1917# find and load all maps in the 3x3 area around a map
1918sub load_neighbours {
716 my ($map) = @_; 1919 my ($map) = @_;
717 1920
718 my $path = $map->tmpname; 1921 my @neigh; # diagonal neighbours
719 defined $path or return;
720 1922
721 unlink "$path.pst"; 1923 for (0 .. 3) {
722}; 1924 my $neigh = $map->tile_path ($_)
1925 or next;
1926 $neigh = find $neigh, $map
1927 or next;
1928 $neigh->load;
723 1929
724cf::map->attach (prio => -10000, package => cf::mapsupport::); 1930 push @neigh,
1931 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1932 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1933 }
725 1934
726############################################################################# 1935 for (grep defined $_->[0], @neigh) {
727# load/save perl data associated with player->ob objects 1936 my ($path, $origin) = @$_;
728 1937 my $neigh = find $path, $origin
729sub all_objects(@) { 1938 or next;
730 @_, map all_objects ($_->inv), @_ 1939 $neigh->load;
1940 }
731} 1941}
732 1942
733# TODO: compatibility cruft, remove when no longer needed 1943sub find_sync {
734cf::player->attach ( 1944 my ($path, $origin) = @_;
735 on_load => sub {
736 my ($pl, $path) = @_;
737 1945
738 for my $o (all_objects $pl->ob) { 1946 cf::sync_job { find $path, $origin }
739 if (my $value = $o->get_ob_key_value ("_perl_data")) { 1947}
740 $o->set_ob_key_value ("_perl_data");
741 1948
742 %$o = %{ Storable::thaw pack "H*", $value }; 1949sub do_load_sync {
1950 my ($map) = @_;
1951
1952 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
1953 if $Coro::current == $Coro::main;
1954
1955 cf::sync_job { $map->load };
1956}
1957
1958our %MAP_PREFETCH;
1959our $MAP_PREFETCHER = undef;
1960
1961sub find_async {
1962 my ($path, $origin, $load) = @_;
1963
1964 $path = normalise $path, $origin && $origin->{path};
1965
1966 if (my $map = $cf::MAP{$path}) {
1967 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1968 }
1969
1970 $MAP_PREFETCH{$path} |= $load;
1971
1972 $MAP_PREFETCHER ||= cf::async {
1973 while (%MAP_PREFETCH) {
1974 while (my ($k, $v) = each %MAP_PREFETCH) {
1975 if (my $map = find $k) {
1976 $map->load if $v;
1977 }
1978
1979 delete $MAP_PREFETCH{$k};
743 } 1980 }
744 } 1981 }
1982 undef $MAP_PREFETCHER;
1983 };
1984 $MAP_PREFETCHER->prio (6);
1985
1986 ()
1987}
1988
1989sub save {
1990 my ($self) = @_;
1991
1992 my $lock = cf::lock_acquire "map_data:" . $self->path;
1993
1994 $self->{last_save} = $cf::RUNTIME;
1995
1996 return unless $self->dirty;
1997
1998 my $save = $self->save_path; utf8::encode $save;
1999 my $uniq = $self->uniq_path; utf8::encode $uniq;
2000
2001 $self->{load_path} = $save;
2002
2003 return if $self->{deny_save};
2004
2005 local $self->{last_access} = $self->last_access;#d#
2006
2007 cf::async {
2008 $_->contr->save for $self->players;
2009 };
2010
2011 if ($uniq) {
2012 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2013 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2014 } else {
2015 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
745 }, 2016 }
746); 2017}
747 2018
748############################################################################# 2019sub swap_out {
2020 my ($self) = @_;
749 2021
750=head2 CORE EXTENSIONS 2022 # save first because save cedes
2023 $self->save;
751 2024
752Functions and methods that extend core crossfire objects. 2025 my $lock = cf::lock_acquire "map_data:" . $self->path;
753 2026
754=head3 cf::player 2027 return if $self->players;
2028 return if $self->in_memory != cf::MAP_IN_MEMORY;
2029 return if $self->{deny_save};
2030
2031 $self->clear;
2032 $self->in_memory (cf::MAP_SWAPPED);
2033}
2034
2035sub reset_at {
2036 my ($self) = @_;
2037
2038 # TODO: safety, remove and allow resettable per-player maps
2039 return 1e99 if $self->{deny_reset};
2040
2041 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2042 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2043
2044 $time + $to
2045}
2046
2047sub should_reset {
2048 my ($self) = @_;
2049
2050 $self->reset_at <= $cf::RUNTIME
2051}
2052
2053sub reset {
2054 my ($self) = @_;
2055
2056 my $lock = cf::lock_acquire "map_data:$self->{path}";
2057
2058 return if $self->players;
2059
2060 warn "resetting map ", $self->path;
2061
2062 $self->in_memory (cf::MAP_SWAPPED);
2063
2064 # need to save uniques path
2065 unless ($self->{deny_save}) {
2066 my $uniq = $self->uniq_path; utf8::encode $uniq;
2067
2068 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2069 if $uniq;
2070 }
2071
2072 delete $cf::MAP{$self->path};
2073
2074 $self->clear;
2075
2076 $_->clear_links_to ($self) for values %cf::MAP;
2077
2078 $self->unlink_save;
2079 $self->destroy;
2080}
2081
2082my $nuke_counter = "aaaa";
2083
2084sub nuke {
2085 my ($self) = @_;
2086
2087 delete $cf::MAP{$self->path};
2088
2089 $self->unlink_save;
2090
2091 bless $self, "cf::map";
2092 delete $self->{deny_reset};
2093 $self->{deny_save} = 1;
2094 $self->reset_timeout (1);
2095 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2096
2097 $cf::MAP{$self->path} = $self;
2098
2099 $self->reset; # polite request, might not happen
2100}
2101
2102=item $maps = cf::map::tmp_maps
2103
2104Returns an arrayref with all map paths of currently instantiated and saved
2105maps. May block.
2106
2107=cut
2108
2109sub tmp_maps() {
2110 [
2111 map {
2112 utf8::decode $_;
2113 /\.map$/
2114 ? normalise $_
2115 : ()
2116 } @{ aio_readdir $TMPDIR or [] }
2117 ]
2118}
2119
2120=item $maps = cf::map::random_maps
2121
2122Returns an arrayref with all map paths of currently instantiated and saved
2123random maps. May block.
2124
2125=cut
2126
2127sub random_maps() {
2128 [
2129 map {
2130 utf8::decode $_;
2131 /\.map$/
2132 ? normalise "?random/$_"
2133 : ()
2134 } @{ aio_readdir $RANDOMDIR or [] }
2135 ]
2136}
2137
2138=item cf::map::unique_maps
2139
2140Returns an arrayref of paths of all shared maps that have
2141instantiated unique items. May block.
2142
2143=cut
2144
2145sub unique_maps() {
2146 [
2147 map {
2148 utf8::decode $_;
2149 /\.map$/
2150 ? normalise $_
2151 : ()
2152 } @{ aio_readdir $UNIQUEDIR or [] }
2153 ]
2154}
2155
2156package cf;
2157
2158=back
2159
2160=head3 cf::object
2161
2162=cut
2163
2164package cf::object;
755 2165
756=over 4 2166=over 4
757 2167
758=item cf::player::exists $login 2168=item $ob->inv_recursive
759 2169
760Returns true when the given account exists. 2170Returns the inventory of the object _and_ their inventories, recursively.
761 2171
762=cut 2172=cut
763 2173
764sub cf::player::exists($) { 2174sub inv_recursive_;
765 cf::player::find $_[0] 2175sub inv_recursive_ {
766 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 2176 map { $_, inv_recursive_ $_->inv } @_
767} 2177}
768 2178
769=item $player->ext_reply ($msgid, $msgtype, %msg) 2179sub inv_recursive {
770 2180 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} 2181}
2182
2183package cf;
782 2184
783=back 2185=back
784 2186
785=head3 cf::object::player 2187=head3 cf::object::player
786 2188
… …
802 2204
803 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2205 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
804 2206
805 if ($self->{record_replies}) { 2207 if ($self->{record_replies}) {
806 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2208 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2209
807 } else { 2210 } else {
2211 my $pl = $self->contr;
2212
2213 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2214 my $dialog = $pl->{npc_dialog};
2215 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2216
2217 } else {
808 $msg = $npc->name . " says: $msg" if $npc; 2218 $msg = $npc->name . " says: $msg" if $npc;
809 $self->message ($msg, $flags); 2219 $self->message ($msg, $flags);
2220 }
810 } 2221 }
2222}
2223
2224=item $object->send_msg ($channel, $msg, $color, [extra...])
2225
2226=cut
2227
2228sub cf::object::send_msg {
2229 my $pl = shift->contr
2230 or return;
2231 $pl->send_msg (@_);
811} 2232}
812 2233
813=item $player_object->may ("access") 2234=item $player_object->may ("access")
814 2235
815Returns wether the given player is authorized to access resource "access" 2236Returns wether the given player is authorized to access resource "access"
… …
824 (ref $cf::CFG{"may_$access"} 2245 (ref $cf::CFG{"may_$access"}
825 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 2246 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
826 : $cf::CFG{"may_$access"}) 2247 : $cf::CFG{"may_$access"})
827} 2248}
828 2249
2250=item $player_object->enter_link
2251
2252Freezes the player and moves him/her to a special map (C<{link}>).
2253
2254The player should be reasonably safe there for short amounts of time. You
2255I<MUST> call C<leave_link> as soon as possible, though.
2256
2257Will never block.
2258
2259=item $player_object->leave_link ($map, $x, $y)
2260
2261Moves the player out of the special C<{link}> map onto the specified
2262map. If the map is not valid (or omitted), the player will be moved back
2263to the location he/she was before the call to C<enter_link>, or, if that
2264fails, to the emergency map position.
2265
2266Might block.
2267
2268=cut
2269
2270sub link_map {
2271 unless ($LINK_MAP) {
2272 $LINK_MAP = cf::map::find "{link}"
2273 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
2274 $LINK_MAP->load;
2275 }
2276
2277 $LINK_MAP
2278}
2279
2280sub cf::object::player::enter_link {
2281 my ($self) = @_;
2282
2283 $self->deactivate_recursive;
2284
2285 return if UNIVERSAL::isa $self->map, "ext::map_link";
2286
2287 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2288 if $self->map && $self->map->{path} ne "{link}";
2289
2290 $self->enter_map ($LINK_MAP || link_map, 10, 10);
2291}
2292
2293sub cf::object::player::leave_link {
2294 my ($self, $map, $x, $y) = @_;
2295
2296 return unless $self->contr->active;
2297
2298 my $link_pos = delete $self->{_link_pos};
2299
2300 unless ($map) {
2301 # restore original map position
2302 ($map, $x, $y) = @{ $link_pos || [] };
2303 $map = cf::map::find $map;
2304
2305 unless ($map) {
2306 ($map, $x, $y) = @$EMERGENCY_POSITION;
2307 $map = cf::map::find $map
2308 or die "FATAL: cannot load emergency map\n";
2309 }
2310 }
2311
2312 ($x, $y) = (-1, -1)
2313 unless (defined $x) && (defined $y);
2314
2315 # use -1 or undef as default coordinates, not 0, 0
2316 ($x, $y) = ($map->enter_x, $map->enter_y)
2317 if $x <=0 && $y <= 0;
2318
2319 $map->load;
2320 $map->load_neighbours;
2321
2322 return unless $self->contr->active;
2323 $self->activate_recursive;
2324
2325 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2326 $self->enter_map ($map, $x, $y);
2327}
2328
2329=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2330
2331Moves the player to the given map-path and coordinates by first freezing
2332her, loading and preparing them map, calling the provided $check callback
2333that has to return the map if sucecssful, and then unfreezes the player on
2334the new (success) or old (failed) map position. In either case, $done will
2335be called at the end of this process.
2336
2337=cut
2338
2339our $GOTOGEN;
2340
2341sub cf::object::player::goto {
2342 my ($self, $path, $x, $y, $check, $done) = @_;
2343
2344 # do generation counting so two concurrent goto's will be executed in-order
2345 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2346
2347 $self->enter_link;
2348
2349 (async {
2350 my $map = eval {
2351 my $map = cf::map::find $path;
2352
2353 if ($map) {
2354 $map = $map->customise_for ($self);
2355 $map = $check->($map) if $check && $map;
2356 } else {
2357 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2358 }
2359
2360 $map
2361 };
2362
2363 if ($@) {
2364 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2365 LOG llevError | logBacktrace, Carp::longmess $@;
2366 }
2367
2368 if ($gen == $self->{_goto_generation}) {
2369 delete $self->{_goto_generation};
2370 $self->leave_link ($map, $x, $y);
2371 }
2372
2373 $done->() if $done;
2374 })->prio (1);
2375}
2376
2377=item $player_object->enter_exit ($exit_object)
2378
2379=cut
2380
2381sub parse_random_map_params {
2382 my ($spec) = @_;
2383
2384 my $rmp = { # defaults
2385 xsize => (cf::rndm 15, 40),
2386 ysize => (cf::rndm 15, 40),
2387 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2388 #layout => string,
2389 };
2390
2391 for (split /\n/, $spec) {
2392 my ($k, $v) = split /\s+/, $_, 2;
2393
2394 $rmp->{lc $k} = $v if (length $k) && (length $v);
2395 }
2396
2397 $rmp
2398}
2399
2400sub prepare_random_map {
2401 my ($exit) = @_;
2402
2403 my $guard = cf::lock_acquire "exit_prepare:$exit";
2404
2405 # all this does is basically replace the /! path by
2406 # a new random map path (?random/...) with a seed
2407 # that depends on the exit object
2408
2409 my $rmp = parse_random_map_params $exit->msg;
2410
2411 if ($exit->map) {
2412 $rmp->{region} = $exit->region->name;
2413 $rmp->{origin_map} = $exit->map->path;
2414 $rmp->{origin_x} = $exit->x;
2415 $rmp->{origin_y} = $exit->y;
2416 }
2417
2418 $rmp->{random_seed} ||= $exit->random_seed;
2419
2420 my $data = cf::to_json $rmp;
2421 my $md5 = Digest::MD5::md5_hex $data;
2422 my $meta = "$RANDOMDIR/$md5.meta";
2423
2424 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2425 aio_write $fh, 0, (length $data), $data, 0;
2426 undef $fh;
2427 aio_rename "$meta~", $meta;
2428
2429 $exit->slaying ("?random/$md5");
2430 $exit->msg (undef);
2431 }
2432}
2433
2434sub cf::object::player::enter_exit {
2435 my ($self, $exit) = @_;
2436
2437 return unless $self->type == cf::PLAYER;
2438
2439 if ($exit->slaying eq "/!") {
2440 #TODO: this should de-fi-ni-te-ly not be a sync-job
2441 # the problem is that $exit might not survive long enough
2442 # so it needs to be done right now, right here
2443 cf::sync_job { prepare_random_map $exit };
2444 }
2445
2446 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2447 my $hp = $exit->stats->hp;
2448 my $sp = $exit->stats->sp;
2449
2450 $self->enter_link;
2451
2452 # if exit is damned, update players death & WoR home-position
2453 $self->contr->savebed ($slaying, $hp, $sp)
2454 if $exit->flag (FLAG_DAMNED);
2455
2456 (async {
2457 $self->deactivate_recursive; # just to be sure
2458 unless (eval {
2459 $self->goto ($slaying, $hp, $sp);
2460
2461 1;
2462 }) {
2463 $self->message ("Something went wrong deep within the crossfire server. "
2464 . "I'll try to bring you back to the map you were before. "
2465 . "Please report this to the dungeon master!",
2466 cf::NDI_UNIQUE | cf::NDI_RED);
2467
2468 warn "ERROR in enter_exit: $@";
2469 $self->leave_link;
2470 }
2471 })->prio (1);
2472}
2473
829=head3 cf::client 2474=head3 cf::client
830 2475
831=over 4 2476=over 4
832 2477
833=item $client->send_drawinfo ($text, $flags) 2478=item $client->send_drawinfo ($text, $flags)
… …
839 2484
840sub cf::client::send_drawinfo { 2485sub cf::client::send_drawinfo {
841 my ($self, $text, $flags) = @_; 2486 my ($self, $text, $flags) = @_;
842 2487
843 utf8::encode $text; 2488 utf8::encode $text;
844 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2489 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
845} 2490}
846 2491
2492=item $client->send_msg ($channel, $msg, $color, [extra...])
2493
2494Send a drawinfo or msg packet to the client, formatting the msg for the
2495client if neccessary. C<$type> should be a string identifying the type of
2496the message, with C<log> being the default. If C<$color> is negative, suppress
2497the message unless the client supports the msg packet.
2498
2499=cut
2500
2501sub cf::client::send_msg {
2502 my ($self, $channel, $msg, $color, @extra) = @_;
2503
2504 $msg = $self->pl->expand_cfpod ($msg);
2505
2506 $color &= cf::NDI_CLIENT_MASK; # just in case...
2507
2508 if (ref $channel) {
2509 # send meta info to client, if not yet sent
2510 unless (exists $self->{channel}{$channel->{id}}) {
2511 $self->{channel}{$channel->{id}} = $channel;
2512 $self->ext_msg (channel_info => $channel);
2513 }
2514
2515 $channel = $channel->{id};
2516 }
2517
2518 return unless @extra || length $msg;
2519
2520 if ($self->can_msg) {
2521 # default colour, mask it out
2522 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2523 if $color & cf::NDI_DEF;
2524
2525 $self->send_packet ("msg " . $self->{json_coder}->encode (
2526 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2527 } else {
2528 if ($color >= 0) {
2529 # replace some tags by gcfclient-compatible ones
2530 for ($msg) {
2531 1 while
2532 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2533 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2534 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2535 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2536 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2537 }
2538
2539 $color &= cf::NDI_COLOR_MASK;
2540
2541 utf8::encode $msg;
2542
2543 if (0 && $msg =~ /\[/) {
2544 # COMMAND/INFO
2545 $self->send_packet ("drawextinfo $color 10 8 $msg")
2546 } else {
2547 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2548 $self->send_packet ("drawinfo $color $msg")
2549 }
2550 }
2551 }
2552}
2553
2554=item $client->ext_msg ($type, @msg)
2555
2556Sends an ext event to the client.
2557
2558=cut
2559
2560sub cf::client::ext_msg($$@) {
2561 my ($self, $type, @msg) = @_;
2562
2563 my $extcmd = $self->extcmd;
2564
2565 if ($extcmd == 2) {
2566 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2567 } elsif ($extcmd == 1) { # TODO: remove
2568 push @msg, msgtype => "event_$type";
2569 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2570 }
2571}
2572
2573=item $client->ext_reply ($msgid, @msg)
2574
2575Sends an ext reply to the client.
2576
2577=cut
2578
2579sub cf::client::ext_reply($$@) {
2580 my ($self, $id, @msg) = @_;
2581
2582 if ($self->extcmd == 2) {
2583 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2584 } elsif ($self->ns->extcmd == 1) {
2585 #TODO: version 1, remove
2586 unshift @msg, msgtype => "reply", msgid => $id;
2587 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2588 }
2589}
847 2590
848=item $success = $client->query ($flags, "text", \&cb) 2591=item $success = $client->query ($flags, "text", \&cb)
849 2592
850Queues a query to the client, calling the given callback with 2593Queues a query to the client, calling the given callback with
851the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2594the 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>. 2595C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
853 2596
854Queries can fail, so check the return code. Or don't, as queries will become 2597Queries can fail, so check the return code. Or don't, as queries will
855reliable at some point in the future. 2598become reliable at some point in the future.
856 2599
857=cut 2600=cut
858 2601
859sub cf::client::query { 2602sub cf::client::query {
860 my ($self, $flags, $text, $cb) = @_; 2603 my ($self, $flags, $text, $cb) = @_;
… …
868 utf8::encode $text; 2611 utf8::encode $text;
869 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2612 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
870 2613
871 $self->send_packet ($self->{query_queue}[0][0]) 2614 $self->send_packet ($self->{query_queue}[0][0])
872 if @{ $self->{query_queue} } == 1; 2615 if @{ $self->{query_queue} } == 1;
2616
2617 1
873} 2618}
874 2619
875cf::client->attach ( 2620cf::client->attach (
2621 on_connect => sub {
2622 my ($ns) = @_;
2623
2624 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2625 },
876 on_reply => sub { 2626 on_reply => sub {
877 my ($ns, $msg) = @_; 2627 my ($ns, $msg) = @_;
878 2628
879 # this weird shuffling is so that direct followup queries 2629 # this weird shuffling is so that direct followup queries
880 # get handled first 2630 # get handled first
881 my $queue = delete $ns->{query_queue}; 2631 my $queue = delete $ns->{query_queue}
2632 or return; # be conservative, not sure how that can happen, but we saw a crash here
882 2633
883 (shift @$queue)->[1]->($msg); 2634 (shift @$queue)->[1]->($msg);
2635 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
884 2636
885 push @{ $ns->{query_queue} }, @$queue; 2637 push @{ $ns->{query_queue} }, @$queue;
886 2638
887 if (@{ $ns->{query_queue} } == @$queue) { 2639 if (@{ $ns->{query_queue} } == @$queue) {
888 if (@$queue) { 2640 if (@$queue) {
889 $ns->send_packet ($ns->{query_queue}[0][0]); 2641 $ns->send_packet ($ns->{query_queue}[0][0]);
890 } else { 2642 } else {
891 $ns->state (ST_PLAYING); 2643 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
892 } 2644 }
893 } 2645 }
2646 },
2647 on_exticmd => sub {
2648 my ($ns, $buf) = @_;
2649
2650 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2651
2652 if (ref $msg) {
2653 my ($type, $reply, @payload) =
2654 "ARRAY" eq ref $msg
2655 ? @$msg
2656 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2657
2658 my @reply;
2659
2660 if (my $cb = $EXTICMD{$type}) {
2661 @reply = $cb->($ns, @payload);
2662 }
2663
2664 $ns->ext_reply ($reply, @reply)
2665 if $reply;
2666
2667 } else {
2668 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2669 }
2670
2671 cf::override;
894 }, 2672 },
895); 2673);
896 2674
897=item $client->coro (\&cb) 2675=item $client->async (\&cb)
898 2676
899Create a new coroutine, running the specified callback. The coroutine will 2677Create a new coroutine, running the specified callback. The coroutine will
900be automatically cancelled when the client gets destroyed (e.g. on logout, 2678be automatically cancelled when the client gets destroyed (e.g. on logout,
901or loss of connection). 2679or loss of connection).
902 2680
903=cut 2681=cut
904 2682
905sub cf::client::coro { 2683sub cf::client::async {
906 my ($self, $cb) = @_; 2684 my ($self, $cb) = @_;
907 2685
908 my $coro; $coro = async { 2686 my $coro = &Coro::async ($cb);
909 eval { 2687
910 $cb->(); 2688 $coro->on_destroy (sub {
911 };
912 warn $@ if $@;
913 warn "cancel myself\n";#d#
914 delete $self->{_coro}{$coro+0}; 2689 delete $self->{_coro}{$coro+0};
915 }; 2690 });
916 2691
917 $self->{_coro}{$coro+0} = $coro; 2692 $self->{_coro}{$coro+0} = $coro;
2693
2694 $coro
918} 2695}
919 2696
920cf::client->attach ( 2697cf::client->attach (
921 on_destroy => sub { 2698 on_destroy => sub {
922 my ($ns) = @_; 2699 my ($ns) = @_;
923 2700
924 warn "cancel $_" for values %{ $ns->{_coro} || {} };#d#
925 $_->cancel for values %{ $ns->{_coro} || {} }; 2701 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
926 }, 2702 },
927); 2703);
928 2704
929=back 2705=back
930 2706
… …
942our $safe = new Safe "safe"; 2718our $safe = new Safe "safe";
943our $safe_hole = new Safe::Hole; 2719our $safe_hole = new Safe::Hole;
944 2720
945$SIG{FPE} = 'IGNORE'; 2721$SIG{FPE} = 'IGNORE';
946 2722
947$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2723$safe->permit_only (Opcode::opset qw(
2724 :base_core :base_mem :base_orig :base_math
2725 grepstart grepwhile mapstart mapwhile
2726 sort time
2727));
948 2728
949# here we export the classes and methods available to script code 2729# here we export the classes and methods available to script code
950 2730
951=pod 2731=pod
952 2732
953The following fucntions and emthods are available within a safe environment: 2733The following functions and methods are available within a safe environment:
954 2734
955 cf::object contr pay_amount pay_player map 2735 cf::object
2736 contr pay_amount pay_player map x y force_find force_add
2737 insert remove name archname title slaying race decrease_ob_nr
2738
956 cf::object::player player 2739 cf::object::player
957 cf::player peaceful 2740 player
958 cf::map trigger 2741
2742 cf::player
2743 peaceful
2744
2745 cf::map
2746 trigger
959 2747
960=cut 2748=cut
961 2749
962for ( 2750for (
963 ["cf::object" => qw(contr pay_amount pay_player map)], 2751 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2752 insert remove inv name archname title slaying race
2753 decrease_ob_nr)],
964 ["cf::object::player" => qw(player)], 2754 ["cf::object::player" => qw(player)],
965 ["cf::player" => qw(peaceful)], 2755 ["cf::player" => qw(peaceful)],
966 ["cf::map" => qw(trigger)], 2756 ["cf::map" => qw(trigger)],
967) { 2757) {
968 no strict 'refs'; 2758 no strict 'refs';
… …
1039=back 2829=back
1040 2830
1041=cut 2831=cut
1042 2832
1043############################################################################# 2833#############################################################################
2834# the server's init and main functions
1044 2835
1045=head2 EXTENSION DATABASE SUPPORT 2836sub load_facedata($) {
2837 my ($path) = @_;
1046 2838
1047Crossfire maintains a very simple database for extension use. It can 2839 my $enc = JSON::XS->new->utf8->canonical;
1048currently store anything that can be serialised using Storable, which
1049excludes objects.
1050 2840
1051The parameter C<$family> should best start with the name of the extension 2841 warn "loading facedata from $path\n";
1052using it, it should be unique.
1053 2842
1054=over 4 2843 my $facedata;
2844 0 < aio_load $path, $facedata
2845 or die "$path: $!";
1055 2846
1056=item $hashref = cf::db_get $family 2847 $facedata = Coro::Storable::thaw $facedata;
1057 2848
1058Return a hashref for use by the extension C<$family>, which can be 2849 $facedata->{version} == 2
1059modified. After modifications, you have to call C<cf::db_dirty> or 2850 or cf::cleanup "$path: version mismatch, cannot proceed.";
1060C<cf::db_sync>.
1061 2851
1062=item $value = cf::db_get $family => $key 2852 # patch in the exptable
1063 2853 $facedata->{resource}{"res/exp_table"} = {
1064Returns a single value from the database 2854 type => FT_RSRC,
1065 2855 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
1066=item cf::db_put $family => $hashref
1067
1068Stores the given family hashref into the database. Updates are delayed, if
1069you want the data to be synced to disk immediately, use C<cf::db_sync>.
1070
1071=item cf::db_put $family => $key => $value
1072
1073Stores the given C<$value> in the family hash. Updates are delayed, if you
1074want the data to be synced to disk immediately, use C<cf::db_sync>.
1075
1076=item cf::db_dirty
1077
1078Marks the database as dirty, to be updated at a later time.
1079
1080=item cf::db_sync
1081
1082Immediately write the database to disk I<if it is dirty>.
1083
1084=cut
1085
1086our $DB;
1087
1088{
1089 my $path = cf::localdir . "/database.pst";
1090
1091 sub db_load() {
1092 warn "loading database $path\n";#d# remove later
1093 $DB = stat $path ? Storable::retrieve $path : { };
1094 }
1095
1096 my $pid;
1097
1098 sub db_save() {
1099 warn "saving database $path\n";#d# remove later
1100 waitpid $pid, 0 if $pid;
1101 if (0 == ($pid = fork)) {
1102 $DB->{_meta}{version} = 1;
1103 Storable::nstore $DB, "$path~";
1104 rename "$path~", $path;
1105 cf::_exit 0 if defined $pid;
1106 }
1107 }
1108
1109 my $dirty;
1110
1111 sub db_sync() {
1112 db_save if $dirty;
1113 undef $dirty;
1114 }
1115
1116 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1117 db_sync;
1118 }); 2856 };
2857 cf::cede_to_tick;
1119 2858
1120 sub db_dirty() {
1121 $dirty = 1;
1122 $idle->start;
1123 } 2859 {
2860 my $faces = $facedata->{faceinfo};
1124 2861
1125 sub db_get($;$) { 2862 while (my ($face, $info) = each %$faces) {
1126 @_ >= 2 2863 my $idx = (cf::face::find $face) || cf::face::alloc $face;
1127 ? $DB->{$_[0]}{$_[1]} 2864 cf::face::set_visibility $idx, $info->{visibility};
1128 : ($DB->{$_[0]} ||= { }) 2865 cf::face::set_magicmap $idx, $info->{magicmap};
1129 } 2866 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2867 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
1130 2868
1131 sub db_put($$;$) { 2869 cf::cede_to_tick;
1132 if (@_ >= 3) {
1133 $DB->{$_[0]}{$_[1]} = $_[2];
1134 } else {
1135 $DB->{$_[0]} = $_[1];
1136 }
1137 db_dirty;
1138 }
1139
1140 cf::global->attach (
1141 prio => 10000,
1142 on_cleanup => sub {
1143 db_sync;
1144 }, 2870 }
1145 );
1146}
1147 2871
1148############################################################################# 2872 while (my ($face, $info) = each %$faces) {
1149# the server's main() 2873 next unless $info->{smooth};
2874 my $idx = cf::face::find $face
2875 or next;
2876 if (my $smooth = cf::face::find $info->{smooth}) {
2877 cf::face::set_smooth $idx, $smooth;
2878 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2879 } else {
2880 warn "smooth face '$info->{smooth}' not found for face '$face'";
2881 }
2882
2883 cf::cede_to_tick;
2884 }
2885 }
2886
2887 {
2888 my $anims = $facedata->{animinfo};
2889
2890 while (my ($anim, $info) = each %$anims) {
2891 cf::anim::set $anim, $info->{frames}, $info->{facings};
2892 cf::cede_to_tick;
2893 }
2894
2895 cf::anim::invalidate_all; # d'oh
2896 }
2897
2898 {
2899 # TODO: for gcfclient pleasure, we should give resources
2900 # that gcfclient doesn't grok a >10000 face index.
2901 my $res = $facedata->{resource};
2902
2903 my $soundconf = delete $res->{"res/sound.conf"};
2904
2905 while (my ($name, $info) = each %$res) {
2906 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2907 my $data;
2908
2909 if ($info->{type} & 1) {
2910 # prepend meta info
2911
2912 my $meta = $enc->encode ({
2913 name => $name,
2914 %{ $info->{meta} || {} },
2915 });
2916
2917 $data = pack "(w/a*)*", $meta, $info->{data};
2918 } else {
2919 $data = $info->{data};
2920 }
2921
2922 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2923 cf::face::set_type $idx, $info->{type};
2924
2925 cf::cede_to_tick;
2926 }
2927
2928 if ($soundconf) {
2929 $soundconf = $enc->decode (delete $soundconf->{data});
2930
2931 for (0 .. SOUND_CAST_SPELL_0 - 1) {
2932 my $sound = $soundconf->{compat}[$_]
2933 or next;
2934
2935 my $face = cf::face::find "sound/$sound->[1]";
2936 cf::sound::set $sound->[0] => $face;
2937 cf::sound::old_sound_index $_, $face; # gcfclient-compat
2938 }
2939
2940 while (my ($k, $v) = each %{$soundconf->{event}}) {
2941 my $face = cf::face::find "sound/$v";
2942 cf::sound::set $k => $face;
2943 }
2944 }
2945 }
2946
2947 1
2948}
2949
2950register_exticmd fx_want => sub {
2951 my ($ns, $want) = @_;
2952
2953 while (my ($k, $v) = each %$want) {
2954 $ns->fx_want ($k, $v);
2955 }
2956};
2957
2958sub reload_regions {
2959 load_resource_file "$MAPDIR/regions"
2960 or die "unable to load regions file\n";
2961
2962 for (cf::region::list) {
2963 $_->{match} = qr/$_->{match}/
2964 if exists $_->{match};
2965 }
2966}
2967
2968sub reload_facedata {
2969 load_facedata "$DATADIR/facedata"
2970 or die "unable to load facedata\n";
2971}
2972
2973sub reload_archetypes {
2974 load_resource_file "$DATADIR/archetypes"
2975 or die "unable to load archetypes\n";
2976 #d# NEED to laod twice to resolve forward references
2977 # this really needs to be done in an extra post-pass
2978 # (which needs to be synchronous, so solve it differently)
2979 load_resource_file "$DATADIR/archetypes"
2980 or die "unable to load archetypes\n";
2981}
2982
2983sub reload_treasures {
2984 load_resource_file "$DATADIR/treasures"
2985 or die "unable to load treasurelists\n";
2986}
2987
2988sub reload_resources {
2989 warn "reloading resource files...\n";
2990
2991 reload_regions;
2992 reload_facedata;
2993 #reload_archetypes;#d#
2994 reload_archetypes;
2995 reload_treasures;
2996
2997 warn "finished reloading resource files\n";
2998}
2999
3000sub init {
3001 reload_resources;
3002}
1150 3003
1151sub cfg_load { 3004sub cfg_load {
1152 open my $fh, "<:utf8", cf::confdir . "/config" 3005 open my $fh, "<:utf8", "$CONFDIR/config"
1153 or return; 3006 or return;
1154 3007
1155 local $/; 3008 local $/;
1156 *CFG = YAML::Syck::Load <$fh>; 3009 *CFG = YAML::Syck::Load <$fh>;
3010
3011 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3012
3013 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3014 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3015
3016 if (exists $CFG{mlockall}) {
3017 eval {
3018 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3019 and die "WARNING: m(un)lockall failed: $!\n";
3020 };
3021 warn $@ if $@;
3022 }
1157} 3023}
1158 3024
1159sub main { 3025sub main {
3026 # we must not ever block the main coroutine
3027 local $Coro::idle = sub {
3028 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3029 (async {
3030 Event::one_event;
3031 })->prio (Coro::PRIO_MAX);
3032 };
3033
1160 cfg_load; 3034 cfg_load;
1161 db_load; 3035 db_init;
1162 load_extensions; 3036 load_extensions;
3037
3038 $TICK_WATCHER->start;
1163 Event::loop; 3039 Event::loop;
1164} 3040}
1165 3041
1166############################################################################# 3042#############################################################################
1167# initialisation 3043# initialisation and cleanup
1168 3044
1169sub _perl_reload(&) { 3045# install some emergency cleanup handlers
3046BEGIN {
3047 for my $signal (qw(INT HUP TERM)) {
3048 Event->signal (
3049 reentrant => 0,
3050 data => WF_AUTOCANCEL,
3051 signal => $signal,
3052 prio => 0,
3053 cb => sub {
3054 cf::cleanup "SIG$signal";
3055 },
3056 );
3057 }
3058}
3059
3060sub write_runtime {
3061 my $runtime = "$LOCALDIR/runtime";
3062
3063 # first touch the runtime file to show we are still running:
3064 # the fsync below can take a very very long time.
3065
3066 IO::AIO::aio_utime $runtime, undef, undef;
3067
3068 my $guard = cf::lock_acquire "write_runtime";
3069
3070 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3071 or return;
3072
3073 my $value = $cf::RUNTIME + 90 + 10;
3074 # 10 is the runtime save interval, for a monotonic clock
3075 # 60 allows for the watchdog to kill the server.
3076
3077 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3078 and return;
3079
3080 # always fsync - this file is important
3081 aio_fsync $fh
3082 and return;
3083
3084 # touch it again to show we are up-to-date
3085 aio_utime $fh, undef, undef;
3086
3087 close $fh
3088 or return;
3089
3090 aio_rename "$runtime~", $runtime
3091 and return;
3092
3093 warn "runtime file written.\n";
3094
3095 1
3096}
3097
3098sub emergency_save() {
3099 my $freeze_guard = cf::freeze_mainloop;
3100
3101 warn "enter emergency perl save\n";
3102
3103 cf::sync_job {
3104 # use a peculiar iteration method to avoid tripping on perl
3105 # refcount bugs in for. also avoids problems with players
3106 # and maps saved/destroyed asynchronously.
3107 warn "begin emergency player save\n";
3108 for my $login (keys %cf::PLAYER) {
3109 my $pl = $cf::PLAYER{$login} or next;
3110 $pl->valid or next;
3111 $pl->save;
3112 }
3113 warn "end emergency player save\n";
3114
3115 warn "begin emergency map save\n";
3116 for my $path (keys %cf::MAP) {
3117 my $map = $cf::MAP{$path} or next;
3118 $map->valid or next;
3119 $map->save;
3120 }
3121 warn "end emergency map save\n";
3122
3123 warn "begin emergency database checkpoint\n";
3124 BDB::db_env_txn_checkpoint $DB_ENV;
3125 warn "end emergency database checkpoint\n";
3126 };
3127
3128 warn "leave emergency perl save\n";
3129}
3130
3131sub post_cleanup {
1170 my ($msg) = @_; 3132 my ($make_core) = @_;
1171 3133
1172 $msg->("reloading..."); 3134 warn Carp::longmess "post_cleanup backtrace"
3135 if $make_core;
3136}
1173 3137
1174 eval { 3138sub do_reload_perl() {
1175 # cancel all watchers 3139 # can/must only be called in main
3140 if ($Coro::current != $Coro::main) {
3141 warn "can only reload from main coroutine";
3142 return;
3143 }
3144
3145 warn "reloading...";
3146
3147 warn "entering sync_job";
3148
3149 cf::sync_job {
3150 cf::write_runtime; # external watchdog should not bark
3151 cf::emergency_save;
3152 cf::write_runtime; # external watchdog should not bark
3153
3154 warn "syncing database to disk";
3155 BDB::db_env_txn_checkpoint $DB_ENV;
3156
3157 # if anything goes wrong in here, we should simply crash as we already saved
3158
3159 warn "cancelling all WF_AUTOCANCEL watchers";
1176 for (Event::all_watchers) { 3160 for (Event::all_watchers) {
1177 $_->cancel if $_->data & WF_AUTOCANCEL; 3161 $_->cancel if $_->data & WF_AUTOCANCEL;
1178 } 3162 }
1179 3163
1180 # unload all extensions 3164 warn "flushing outstanding aio requests";
1181 for (@exts) { 3165 for (;;) {
1182 $msg->("unloading <$_>"); 3166 BDB::flush;
1183 unload_extension $_; 3167 IO::AIO::flush;
3168 Coro::cede;
3169 last unless IO::AIO::nreqs || BDB::nreqs;
3170 warn "iterate...";
3171 }
3172
3173 ++$RELOAD;
3174
3175 warn "cancelling all extension coros";
3176 $_->cancel for values %EXT_CORO;
3177 %EXT_CORO = ();
3178
3179 warn "removing commands";
3180 %COMMAND = ();
3181
3182 warn "removing ext/exti commands";
3183 %EXTCMD = ();
3184 %EXTICMD = ();
3185
3186 warn "unloading/nuking all extensions";
3187 for my $pkg (@EXTS) {
3188 warn "... unloading $pkg";
3189
3190 if (my $cb = $pkg->can ("unload")) {
3191 eval {
3192 $cb->($pkg);
3193 1
3194 } or warn "$pkg unloaded, but with errors: $@";
1184 } 3195 }
1185 3196
3197 warn "... nuking $pkg";
3198 Symbol::delete_package $pkg;
3199 }
3200
1186 # unload all modules loaded from $LIBDIR 3201 warn "unloading all perl modules loaded from $LIBDIR";
1187 while (my ($k, $v) = each %INC) { 3202 while (my ($k, $v) = each %INC) {
1188 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3203 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1189 3204
1190 $msg->("removing <$k>"); 3205 warn "... unloading $k";
1191 delete $INC{$k}; 3206 delete $INC{$k};
1192 3207
1193 $k =~ s/\.pm$//; 3208 $k =~ s/\.pm$//;
1194 $k =~ s/\//::/g; 3209 $k =~ s/\//::/g;
1195 3210
… …
1198 } 3213 }
1199 3214
1200 Symbol::delete_package $k; 3215 Symbol::delete_package $k;
1201 } 3216 }
1202 3217
1203 # sync database to disk
1204 cf::db_sync;
1205
1206 # get rid of safe::, as good as possible 3218 warn "getting rid of safe::, as good as possible";
1207 Symbol::delete_package "safe::$_" 3219 Symbol::delete_package "safe::$_"
1208 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region); 3220 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1209 3221
1210 # remove register_script_function callbacks
1211 # TODO
1212
1213 # unload cf.pm "a bit" 3222 warn "unloading cf.pm \"a bit\"";
1214 delete $INC{"cf.pm"}; 3223 delete $INC{"cf.pm"};
3224 delete $INC{"cf/pod.pm"};
1215 3225
1216 # don't, removes xs symbols, too, 3226 # don't, removes xs symbols, too,
1217 # and global variables created in xs 3227 # and global variables created in xs
1218 #Symbol::delete_package __PACKAGE__; 3228 #Symbol::delete_package __PACKAGE__;
1219 3229
1220 # reload cf.pm 3230 warn "unload completed, starting to reload now";
3231
1221 $msg->("reloading cf.pm"); 3232 warn "reloading cf.pm";
1222 require cf; 3233 require cf;
3234 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1223 3235
1224 # load config and database again 3236 warn "loading config and database again";
1225 cf::cfg_load; 3237 cf::cfg_load;
1226 cf::db_load;
1227 3238
1228 # load extensions 3239 warn "loading extensions";
1229 $msg->("load extensions");
1230 cf::load_extensions; 3240 cf::load_extensions;
1231 3241
1232 # reattach attachments to objects 3242 warn "reattaching attachments to objects/players";
1233 $msg->("reattach"); 3243 _global_reattach; # objects, sockets
1234 _global_reattach; 3244 warn "reattaching attachments to maps";
3245 reattach $_ for values %MAP;
3246 warn "reattaching attachments to players";
3247 reattach $_ for values %PLAYER;
3248
3249 warn "leaving sync_job";
3250
3251 1
3252 } or do {
3253 warn $@;
3254 warn "error while reloading, exiting.";
3255 exit 1;
1235 }; 3256 };
1236 $msg->($@) if $@;
1237 3257
1238 $msg->("reloaded"); 3258 warn "reloaded";
1239}; 3259};
1240 3260
1241sub perl_reload() { 3261our $RELOAD_WATCHER; # used only during reload
1242 _perl_reload { 3262
1243 warn $_[0]; 3263sub reload_perl() {
1244 print "$_[0]\n"; 3264 # doing reload synchronously and two reloads happen back-to-back,
3265 # coro crashes during coro_state_free->destroy here.
3266
3267 $RELOAD_WATCHER ||= Event->timer (
3268 reentrant => 0,
3269 after => 0,
3270 data => WF_AUTOCANCEL,
3271 cb => sub {
3272 do_reload_perl;
3273 undef $RELOAD_WATCHER;
3274 },
1245 }; 3275 );
1246} 3276}
1247 3277
1248register "<global>", __PACKAGE__;
1249
1250register_command "perl-reload" => sub { 3278register_command "reload" => sub {
1251 my ($who, $arg) = @_; 3279 my ($who, $arg) = @_;
1252 3280
1253 if ($who->flag (FLAG_WIZ)) { 3281 if ($who->flag (FLAG_WIZ)) {
1254 _perl_reload { 3282 $who->message ("reloading server.");
1255 warn $_[0]; 3283 async { reload_perl };
1256 $who->message ($_[0]); 3284 }
3285};
3286
3287unshift @INC, $LIBDIR;
3288
3289my $bug_warning = 0;
3290
3291our @WAIT_FOR_TICK;
3292our @WAIT_FOR_TICK_BEGIN;
3293
3294sub wait_for_tick {
3295 return unless $TICK_WATCHER->is_active;
3296 return if $Coro::current == $Coro::main;
3297
3298 my $signal = new Coro::Signal;
3299 push @WAIT_FOR_TICK, $signal;
3300 $signal->wait;
3301}
3302
3303sub wait_for_tick_begin {
3304 return unless $TICK_WATCHER->is_active;
3305 return if $Coro::current == $Coro::main;
3306
3307 my $signal = new Coro::Signal;
3308 push @WAIT_FOR_TICK_BEGIN, $signal;
3309 $signal->wait;
3310}
3311
3312 my $min = 1e6;#d#
3313 my $avg = 10;
3314$TICK_WATCHER = Event->timer (
3315 reentrant => 0,
3316 parked => 1,
3317 prio => 0,
3318 at => $NEXT_TICK || $TICK,
3319 data => WF_AUTOCANCEL,
3320 cb => sub {
3321 if ($Coro::current != $Coro::main) {
3322 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3323 unless ++$bug_warning > 10;
3324 return;
3325 }
3326
3327 $NOW = $tick_start = Event::time;
3328
3329 cf::server_tick; # one server iteration
3330
3331 0 && sync_job {#d#
3332 for(1..10) {
3333 my $t = Event::time;
3334 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3335 or die;
3336
3337 $map->width (50);
3338 $map->height (50);
3339 $map->alloc;
3340 $map->_load_objects ("/tmp/x.map", 1);
3341 my $t = Event::time - $t;
3342
3343 #next unless $t < 0.0013;#d#
3344 if ($t < $min) {
3345 $min = $t;
3346 }
3347 $avg = $avg * 0.99 + $t * 0.01;
3348 }
3349 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3350 exit 0;
3351 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
1257 }; 3352 };
1258 }
1259};
1260 3353
1261unshift @INC, $LIBDIR; 3354 $RUNTIME += $TICK;
1262
1263$TICK_WATCHER = Event->timer (
1264 prio => 0,
1265 at => $NEXT_TICK || 1,
1266 data => WF_AUTOCANCEL,
1267 cb => sub {
1268 cf::server_tick; # one server iteration
1269
1270 my $NOW = Event::time;
1271 $NEXT_TICK += $TICK; 3355 $NEXT_TICK += $TICK;
3356
3357 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3358 $NEXT_RUNTIME_WRITE = $NOW + 10;
3359 Coro::async_pool {
3360 write_runtime
3361 or warn "ERROR: unable to write runtime file: $!";
3362 };
3363 }
3364
3365# my $AFTER = Event::time;
3366# warn $AFTER - $NOW;#d#
3367
3368 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3369 $sig->send;
3370 }
3371 while (my $sig = shift @WAIT_FOR_TICK) {
3372 $sig->send;
3373 }
3374
3375 $NOW = Event::time;
1272 3376
1273 # if we are delayed by four ticks or more, skip them all 3377 # if we are delayed by four ticks or more, skip them all
1274 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 3378 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1275 3379
1276 $TICK_WATCHER->at ($NEXT_TICK); 3380 $TICK_WATCHER->at ($NEXT_TICK);
1277 $TICK_WATCHER->start; 3381 $TICK_WATCHER->start;
3382
3383 $LOAD = ($NOW - $tick_start) / $TICK;
3384 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3385
3386 _post_tick;
3387
3388
1278 }, 3389 },
1279); 3390);
1280 3391
3392{
3393 BDB::max_poll_time $TICK * 0.1;
3394 $BDB_POLL_WATCHER = Event->io (
3395 reentrant => 0,
3396 fd => BDB::poll_fileno,
3397 poll => 'r',
3398 prio => 0,
3399 data => WF_AUTOCANCEL,
3400 cb => \&BDB::poll_cb,
3401 );
3402 BDB::min_parallel 8;
3403
3404 BDB::set_sync_prepare {
3405 my $status;
3406 my $current = $Coro::current;
3407 (
3408 sub {
3409 $status = $!;
3410 $current->ready; undef $current;
3411 },
3412 sub {
3413 Coro::schedule while defined $current;
3414 $! = $status;
3415 },
3416 )
3417 };
3418
3419 unless ($DB_ENV) {
3420 $DB_ENV = BDB::db_env_create;
3421
3422 cf::sync_job {
3423 eval {
3424 BDB::db_env_open
3425 $DB_ENV,
3426 $BDBDIR,
3427 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3428 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3429 0666;
3430
3431 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3432
3433 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3434 $DB_ENV->set_lk_detect;
3435 };
3436
3437 cf::cleanup "db_env_open(db): $@" if $@;
3438 };
3439 }
3440}
3441
3442{
3443 IO::AIO::min_parallel 8;
3444
3445 undef $Coro::AIO::WATCHER;
1281IO::AIO::max_poll_time $TICK * 0.2; 3446 IO::AIO::max_poll_time $TICK * 0.1;
1282 3447 $AIO_POLL_WATCHER = Event->io (
1283Event->io (fd => IO::AIO::poll_fileno, 3448 reentrant => 0,
1284 poll => 'r',
1285 prio => 5,
1286 data => WF_AUTOCANCEL, 3449 data => WF_AUTOCANCEL,
3450 fd => IO::AIO::poll_fileno,
3451 poll => 'r',
3452 prio => 6,
1287 cb => \&IO::AIO::poll_cb); 3453 cb => \&IO::AIO::poll_cb,
3454 );
3455}
3456
3457my $_log_backtrace;
3458
3459sub _log_backtrace {
3460 my ($msg, @addr) = @_;
3461
3462 $msg =~ s/\n//;
3463
3464 # limit the # of concurrent backtraces
3465 if ($_log_backtrace < 2) {
3466 ++$_log_backtrace;
3467 async {
3468 my @bt = fork_call {
3469 @addr = map { sprintf "%x", $_ } @addr;
3470 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3471 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3472 or die "addr2line: $!";
3473
3474 my @funcs;
3475 my @res = <$fh>;
3476 chomp for @res;
3477 while (@res) {
3478 my ($func, $line) = splice @res, 0, 2, ();
3479 push @funcs, "[$func] $line";
3480 }
3481
3482 @funcs
3483 };
3484
3485 LOG llevInfo, "[ABT] $msg\n";
3486 LOG llevInfo, "[ABT] $_\n" for @bt;
3487 --$_log_backtrace;
3488 };
3489 } else {
3490 LOG llevInfo, "[ABT] $msg\n";
3491 LOG llevInfo, "[ABT] [suppressed]\n";
3492 }
3493}
3494
3495# load additional modules
3496use cf::pod;
3497
3498END { cf::emergency_save }
1288 3499
12891 35001
1290 3501

Diff Legend

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