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.219 by root, Sat Feb 17 03:19:44 2007 UTC vs.
Revision 1.288 by root, Mon Jun 25 07:40:53 2007 UTC

3use utf8; 3use utf8;
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket;
8use Storable; 9use Storable;
10use Event;
9use Opcode; 11use Opcode;
10use Safe; 12use Safe;
11use Safe::Hole; 13use Safe::Hole;
12 14
13use Coro 3.5 (); 15use Coro 3.61 ();
16use Coro::State;
17use Coro::Handle;
14use Coro::Event; 18use Coro::Event;
15use Coro::Timer; 19use Coro::Timer;
16use Coro::Signal; 20use Coro::Signal;
17use Coro::Semaphore; 21use Coro::Semaphore;
18use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable;
19 24
25use JSON::XS 1.4 ();
20use BDB (); 26use BDB ();
21use Data::Dumper; 27use Data::Dumper;
22use Digest::MD5; 28use Digest::MD5;
23use Fcntl; 29use Fcntl;
30use YAML::Syck ();
24use IO::AIO 2.32 (); 31use IO::AIO 2.32 ();
25use YAML::Syck ();
26use Time::HiRes; 32use Time::HiRes;
27use Compress::LZF; 33use Compress::LZF;
28 34
35# configure various modules to our taste
36#
37$Storable::canonical = 1; # reduce rsync transfers
38Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
29Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 39Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
30 40
31use Event; $Event::Eval = 1; # no idea why this is required, but it is 41$Event::Eval = 1; # no idea why this is required, but it is
32
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34 42
35# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 43# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
36$YAML::Syck::ImplicitUnicode = 1; 44$YAML::Syck::ImplicitUnicode = 1;
37 45
38$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 46$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
39 47
48sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
49
40our %COMMAND = (); 50our %COMMAND = ();
41our %COMMAND_TIME = (); 51our %COMMAND_TIME = ();
42 52
43our @EXTS = (); # list of extension package names 53our @EXTS = (); # list of extension package names
44our %EXTCMD = (); 54our %EXTCMD = ();
55our %EXTICMD = ();
45our %EXT_CORO = (); # coroutines bound to extensions 56our %EXT_CORO = (); # coroutines bound to extensions
46our %EXT_MAP = (); # pluggable maps 57our %EXT_MAP = (); # pluggable maps
47 58
59our $RELOAD; # number of reloads so far
48our @EVENT; 60our @EVENT;
49our $LIBDIR = datadir . "/ext";
50 61
51our $TICK = MAX_TIME * 1e-6; 62our $CONFDIR = confdir;
63our $DATADIR = datadir;
64our $LIBDIR = "$DATADIR/ext";
65our $PODDIR = "$DATADIR/pod";
66our $MAPDIR = "$DATADIR/" . mapdir;
67our $LOCALDIR = localdir;
68our $TMPDIR = "$LOCALDIR/" . tmpdir;
69our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
70our $PLAYERDIR = "$LOCALDIR/" . playerdir;
71our $RANDOMDIR = "$LOCALDIR/random";
72our $BDBDIR = "$LOCALDIR/db";
73
74our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
52our $TICK_WATCHER; 75our $TICK_WATCHER;
53our $AIO_POLL_WATCHER; 76our $AIO_POLL_WATCHER;
54our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 77our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
55our $NEXT_TICK; 78our $NEXT_TICK;
56our $NOW; 79our $NOW;
65our $RUNTIME; 88our $RUNTIME;
66 89
67our %PLAYER; # all users 90our %PLAYER; # all users
68our %MAP; # all maps 91our %MAP; # all maps
69our $LINK_MAP; # the special {link} map, which is always available 92our $LINK_MAP; # the special {link} map, which is always available
70our $RANDOM_MAPS = cf::localdir . "/random";
71our $BDB_ENV_DIR = cf::localdir . "/db";
72
73our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
74our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
75 93
76# used to convert map paths into valid unix filenames by replacing / by ∕ 94# used to convert map paths into valid unix filenames by replacing / by ∕
77our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 95our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
78 96
97our $LOAD; # a number between 0 (idle) and 1 (too many objects)
98our $LOADAVG; # same thing, but with alpha-smoothing
99our $tick_start; # for load detecting purposes
100
79binmode STDOUT; 101binmode STDOUT;
80binmode STDERR; 102binmode STDERR;
81 103
82# read virtual server time, if available 104# read virtual server time, if available
83unless ($RUNTIME || !-e cf::localdir . "/runtime") { 105unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
84 open my $fh, "<", cf::localdir . "/runtime" 106 open my $fh, "<", "$LOCALDIR/runtime"
85 or die "unable to read runtime file: $!"; 107 or die "unable to read runtime file: $!";
86 $RUNTIME = <$fh> + 0.; 108 $RUNTIME = <$fh> + 0.;
87} 109}
88 110
89mkdir cf::localdir; 111mkdir $_
90mkdir cf::localdir . "/" . cf::playerdir; 112 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
91mkdir cf::localdir . "/" . cf::tmpdir;
92mkdir cf::localdir . "/" . cf::uniquedir;
93mkdir $RANDOM_MAPS;
94mkdir $BDB_ENV_DIR;
95 113
96our $EMERGENCY_POSITION; 114our $EMERGENCY_POSITION;
97 115
98sub cf::map::normalise; 116sub cf::map::normalise;
99 117
110=item $cf::RUNTIME 128=item $cf::RUNTIME
111 129
112The time this server has run, starts at 0 and is increased by $cf::TICK on 130The time this server has run, starts at 0 and is increased by $cf::TICK on
113every server tick. 131every server tick.
114 132
115=item $cf::LIBDIR 133=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
134$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
135$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
116 136
117The perl library directory, where extensions and cf-specific modules can 137Various directories - "/etc", read-only install directory, perl-library
118be found. It will be added to C<@INC> automatically. 138directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
139unique-items directory, player file directory, random maps directory and
140database environment.
119 141
120=item $cf::NOW 142=item $cf::NOW
121 143
122The time of the last (current) server tick. 144The time of the last (current) server tick.
123 145
124=item $cf::TICK 146=item $cf::TICK
125 147
126The interval between server ticks, in seconds. 148The interval between server ticks, in seconds.
149
150=item $cf::LOADAVG
151
152The current CPU load on the server (alpha-smoothed), as a value between 0
153(none) and 1 (overloaded), indicating how much time is spent on processing
154objects per tick. Healthy values are < 0.5.
155
156=item $cf::LOAD
157
158The raw value load value from the last tick.
127 159
128=item %cf::CFG 160=item %cf::CFG
129 161
130Configuration for the server, loaded from C</etc/crossfire/config>, or 162Configuration for the server, loaded from C</etc/crossfire/config>, or
131from wherever your confdir points to. 163from wherever your confdir points to.
132 164
133=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 165=item cf::wait_for_tick, cf::wait_for_tick_begin
134 166
135These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK) 167These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
136or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick 168returns directly I<after> the tick processing (and consequently, can only wake one process
137processing has been done. Call C<< ->wait >> on them to maximise the 169per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
138window of cpu time available, or simply to synchronise to the server tick.
139 170
140=back 171=back
141 172
142=cut 173=cut
143 174
144BEGIN { 175BEGIN {
145 *CORE::GLOBAL::warn = sub { 176 *CORE::GLOBAL::warn = sub {
146 my $msg = join "", @_; 177 my $msg = join "", @_;
147 utf8::encode $msg;
148 178
149 $msg .= "\n" 179 $msg .= "\n"
150 unless $msg =~ /\n$/; 180 unless $msg =~ /\n$/;
151 181
182 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
183
184 utf8::encode $msg;
152 LOG llevError, $msg; 185 LOG llevError, $msg;
153 }; 186 };
154} 187}
155 188
156@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 189@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
157@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 190@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
158@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 191@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
159@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 192@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
160@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 193@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
194@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
161@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 195@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
162 196
163# we bless all objects into (empty) derived classes to force a method lookup 197# we bless all objects into (empty) derived classes to force a method lookup
164# within the Safe compartment. 198# within the Safe compartment.
165for my $pkg (qw( 199for my $pkg (qw(
166 cf::global cf::attachable 200 cf::global cf::attachable
174} 208}
175 209
176$Event::DIED = sub { 210$Event::DIED = sub {
177 warn "error in event callback: @_"; 211 warn "error in event callback: @_";
178}; 212};
213
214#############################################################################
179 215
180=head2 UTILITY FUNCTIONS 216=head2 UTILITY FUNCTIONS
181 217
182=over 4 218=over 4
183 219
202 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 238 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
203 $d 239 $d
204 } || "[unable to dump $_[0]: '$@']"; 240 } || "[unable to dump $_[0]: '$@']";
205} 241}
206 242
207use JSON::Syck (); # TODO# replace by JSON::PC once working
208
209=item $ref = cf::from_json $json 243=item $ref = cf::from_json $json
210 244
211Converts a JSON string into the corresponding perl data structure. 245Converts a JSON string into the corresponding perl data structure.
212 246
213=cut
214
215sub from_json($) {
216 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
217 JSON::Syck::Load $_[0]
218}
219
220=item $json = cf::to_json $ref 247=item $json = cf::to_json $ref
221 248
222Converts a perl data structure into its JSON representation. 249Converts a perl data structure into its JSON representation.
223 250
224=cut 251=cut
225 252
226sub to_json($) { 253our $json_coder = JSON::XS->new->convert_blessed->utf8->max_size (1e6); # accept ~1mb max
227 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 254
228 JSON::Syck::Dump $_[0] 255sub to_json ($) { $json_coder->encode ($_[0]) }
229} 256sub from_json ($) { $json_coder->decode ($_[0]) }
230 257
231=item cf::lock_wait $string 258=item cf::lock_wait $string
232 259
233Wait until the given lock is available. See cf::lock_acquire. 260Wait until the given lock is available. See cf::lock_acquire.
234 261
240returned. 267returned.
241 268
242Lock names should begin with a unique identifier (for example, cf::map::find 269Lock names should begin with a unique identifier (for example, cf::map::find
243uses map_find and cf::map::load uses map_load). 270uses map_find and cf::map::load uses map_load).
244 271
272=item $locked = cf::lock_active $string
273
274Return true if the lock is currently active, i.e. somebody has locked it.
275
245=cut 276=cut
246 277
247our %LOCK; 278our %LOCK;
248 279
249sub lock_wait($) { 280sub lock_wait($) {
266 297
267 Coro::guard { 298 Coro::guard {
268 # wake up all waiters, to be on the safe side 299 # wake up all waiters, to be on the safe side
269 $_->ready for @{ delete $LOCK{$key} }; 300 $_->ready for @{ delete $LOCK{$key} };
270 } 301 }
302}
303
304sub lock_active($) {
305 my ($key) = @_;
306
307 ! ! $LOCK{$key}
271} 308}
272 309
273sub freeze_mainloop { 310sub freeze_mainloop {
274 return unless $TICK_WATCHER->is_active; 311 return unless $TICK_WATCHER->is_active;
275 312
290 327
291BEGIN { *async = \&Coro::async_pool } 328BEGIN { *async = \&Coro::async_pool }
292 329
293=item cf::sync_job { BLOCK } 330=item cf::sync_job { BLOCK }
294 331
295The design of crossfire+ requires that the main coro ($Coro::main) is 332The design of Crossfire TRT requires that the main coroutine ($Coro::main)
296always able to handle events or runnable, as crossfire+ is only partly 333is always able to handle events or runnable, as Crossfire TRT is only
297reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 334partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
335acceptable.
298 336
299If it must be done, put the blocking parts into C<sync_job>. This will run 337If it must be done, put the blocking parts into C<sync_job>. This will run
300the given BLOCK in another coroutine while waiting for the result. The 338the given BLOCK in another coroutine while waiting for the result. The
301server will be frozen during this time, so the block should either finish 339server will be frozen during this time, so the block should either finish
302fast or be very important. 340fast or be very important.
305 343
306sub sync_job(&) { 344sub sync_job(&) {
307 my ($job) = @_; 345 my ($job) = @_;
308 346
309 if ($Coro::current == $Coro::main) { 347 if ($Coro::current == $Coro::main) {
348 my $time = Event::time;
349
310 # this is the main coro, too bad, we have to block 350 # this is the main coro, too bad, we have to block
311 # till the operation succeeds, freezing the server :/ 351 # till the operation succeeds, freezing the server :/
312 352
313 # TODO: use suspend/resume instead 353 # TODO: use suspend/resume instead
314 # (but this is cancel-safe) 354 # (but this is cancel-safe)
325 365
326 while ($busy) { 366 while ($busy) {
327 Coro::cede or Event::one_event; 367 Coro::cede or Event::one_event;
328 } 368 }
329 369
370 $time = Event::time - $time;
371
372 LOG llevError | logBacktrace, Carp::longmess "long sync job"
373 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
374
375 $tick_start += $time; # do not account sync jobs to server load
376
330 wantarray ? @res : $res[0] 377 wantarray ? @res : $res[0]
331 } else { 378 } else {
332 # we are in another coroutine, how wonderful, everything just works 379 # we are in another coroutine, how wonderful, everything just works
333 380
334 $job->() 381 $job->()
353 $EXT_CORO{$coro+0} = $coro; 400 $EXT_CORO{$coro+0} = $coro;
354 401
355 $coro 402 $coro
356} 403}
357 404
358sub write_runtime { 405=item fork_call { }, $args
359 my $guard = cf::lock_acquire "write_runtime";
360 406
361 my $runtime = cf::localdir . "/runtime"; 407Executes the given code block with the given arguments in a seperate
408process, returning the results. Everything must be serialisable with
409Coro::Storable. May, of course, block. Note that the executed sub may
410never block itself or use any form of Event handling.
362 411
363 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 412=cut
364 or return;
365 413
366 my $value = $cf::RUNTIME + 90 + 10; 414sub fork_call(&@) {
367 # 10 is the runtime save interval, for a monotonic clock 415 my ($cb, @args) = @_;
368 # 60 allows for the watchdog to kill the server.
369 416
370 (aio_write $fh, 0, (length $value), $value, 0) <= 0 417# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
371 and return; 418# or die "socketpair: $!";
419 pipe my $fh1, my $fh2
420 or die "pipe: $!";
372 421
373 # always fsync - this file is important 422 if (my $pid = fork) {
374 aio_fsync $fh
375 and return;
376
377 close $fh 423 close $fh2;
378 or return;
379 424
380 aio_rename "$runtime~", $runtime 425 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
381 and return; 426 $res = Coro::Storable::thaw $res;
382 427
428 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
429
430 die $$res unless "ARRAY" eq ref $res;
431
432 return wantarray ? @$res : $res->[-1];
433 } else {
434 reset_signals;
435 local $SIG{__WARN__};
436 local $SIG{__DIE__};
437 eval {
438 close $fh1;
439
440 my @res = eval { $cb->(@args) };
441 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
442 };
443
444 warn $@ if $@;
445 _exit 0;
383 1 446 }
447}
448
449=item $value = cf::db_get $family => $key
450
451Returns a single value from the environment database.
452
453=item cf::db_put $family => $key => $value
454
455Stores the given C<$value> in the family. It can currently store binary
456data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
457
458=cut
459
460our $DB;
461
462sub db_init {
463 unless ($DB) {
464 $DB = BDB::db_create $DB_ENV;
465
466 cf::sync_job {
467 eval {
468 $DB->set_flags (BDB::CHKSUM);
469
470 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
471 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
472 cf::cleanup "db_open(db): $!" if $!;
473 };
474 cf::cleanup "db_open(db): $@" if $@;
475 };
476 }
477}
478
479sub db_get($$) {
480 my $key = "$_[0]/$_[1]";
481
482 cf::sync_job {
483 BDB::db_get $DB, undef, $key, my $data;
484
485 $! ? ()
486 : $data
487 }
488}
489
490sub db_put($$$) {
491 BDB::dbreq_pri 4;
492 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
493}
494
495=item cf::cache $id => [$paths...], $processversion => $process
496
497Generic caching function that returns the value of the resource $id,
498caching and regenerating as required.
499
500This function can block.
501
502=cut
503
504sub cache {
505 my ($id, $src, $processversion, $process) = @_;
506
507 my $meta =
508 join "\x00",
509 $processversion,
510 map {
511 aio_stat $_
512 and Carp::croak "$_: $!";
513
514 ($_, (stat _)[7,9])
515 } @$src;
516
517 my $dbmeta = db_get cache => "$id/meta";
518 if ($dbmeta ne $meta) {
519 # changed, we may need to process
520
521 my @data;
522 my $md5;
523
524 for (0 .. $#$src) {
525 0 <= aio_load $src->[$_], $data[$_]
526 or Carp::croak "$src->[$_]: $!";
527 }
528
529 # if processing is expensive, check
530 # checksum first
531 if (1) {
532 $md5 =
533 join "\x00",
534 $processversion,
535 map {
536 Coro::cede;
537 ($src->[$_], Digest::MD5::md5_hex $data[$_])
538 } 0.. $#$src;
539
540
541 my $dbmd5 = db_get cache => "$id/md5";
542 if ($dbmd5 eq $md5) {
543 db_put cache => "$id/meta", $meta;
544
545 return db_get cache => "$id/data";
546 }
547 }
548
549 my $t1 = Time::HiRes::time;
550 my $data = $process->(\@data);
551 my $t2 = Time::HiRes::time;
552
553 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
554
555 db_put cache => "$id/data", $data;
556 db_put cache => "$id/md5" , $md5;
557 db_put cache => "$id/meta", $meta;
558
559 return $data;
560 }
561
562 db_get cache => "$id/data"
563}
564
565=item cf::datalog type => key => value, ...
566
567Log a datalog packet of the given type with the given key-value pairs.
568
569=cut
570
571sub datalog($@) {
572 my ($type, %kv) = @_;
573 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
384} 574}
385 575
386=back 576=back
387 577
388=cut 578=cut
395attach callbacks/event handlers (a collection of which is called an "attachment") 585attach callbacks/event handlers (a collection of which is called an "attachment")
396to it. All such attachable objects support the following methods. 586to it. All such attachable objects support the following methods.
397 587
398In the following description, CLASS can be any of C<global>, C<object> 588In the following description, CLASS can be any of C<global>, C<object>
399C<player>, C<client> or C<map> (i.e. the attachable objects in 589C<player>, C<client> or C<map> (i.e. the attachable objects in
400crossfire+). 590Crossfire TRT).
401 591
402=over 4 592=over 4
403 593
404=item $attachable->attach ($attachment, key => $value...) 594=item $attachable->attach ($attachment, key => $value...)
405 595
568 $registry = $CB_TYPE[$object_type] ||= []; 758 $registry = $CB_TYPE[$object_type] ||= [];
569 759
570 } elsif ($type eq "subtype") { 760 } elsif ($type eq "subtype") {
571 defined $object_type or Carp::croak "subtype specified without type"; 761 defined $object_type or Carp::croak "subtype specified without type";
572 my $object_subtype = shift @arg; 762 my $object_subtype = shift @arg;
573 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 763 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
574 764
575 } elsif ($type eq "package") { 765 } elsif ($type eq "package") {
576 my $pkg = shift @arg; 766 my $pkg = shift @arg;
577 767
578 while (my ($name, $id) = each %cb_id) { 768 while (my ($name, $id) = each %cb_id) {
607 _attach $registry, $klass, @attach; 797 _attach $registry, $klass, @attach;
608 } 798 }
609 799
610 $obj->{$name} = \%arg; 800 $obj->{$name} = \%arg;
611 } else { 801 } else {
612 warn "object uses attachment '$name' that is not available, postponing.\n"; 802 warn "object uses attachment '$name' which is not available, postponing.\n";
613 } 803 }
614 804
615 $obj->{_attachment}{$name} = undef; 805 $obj->{_attachment}{$name} = undef;
616} 806}
617 807
619 if (ref $_[0]) { 809 if (ref $_[0]) {
620 _object_attach @_; 810 _object_attach @_;
621 } else { 811 } else {
622 _attach shift->_attach_registry, @_; 812 _attach shift->_attach_registry, @_;
623 } 813 }
814 _recalc_want;
624}; 815};
625 816
626# all those should be optimised 817# all those should be optimised
627sub cf::attachable::detach { 818sub cf::attachable::detach {
628 my ($obj, $name) = @_; 819 my ($obj, $name) = @_;
631 delete $obj->{_attachment}{$name}; 822 delete $obj->{_attachment}{$name};
632 reattach ($obj); 823 reattach ($obj);
633 } else { 824 } else {
634 Carp::croak "cannot, currently, detach class attachments"; 825 Carp::croak "cannot, currently, detach class attachments";
635 } 826 }
827 _recalc_want;
636}; 828};
637 829
638sub cf::attachable::attached { 830sub cf::attachable::attached {
639 my ($obj, $name) = @_; 831 my ($obj, $name) = @_;
640 832
813 or return; 1005 or return;
814 $av = eval { (Storable::thaw $av)->{objs} }; 1006 $av = eval { (Storable::thaw $av)->{objs} };
815 } 1007 }
816 1008
817 warn sprintf "loading %s (%d)\n", 1009 warn sprintf "loading %s (%d)\n",
818 $filename, length $data, scalar @{$av || []};#d# 1010 $filename, length $data, scalar @{$av || []};
819 return ($data, $av); 1011 return ($data, $av);
820} 1012}
1013
1014=head2 COMMAND CALLBACKS
1015
1016=over 4
1017
1018=cut
821 1019
822############################################################################# 1020#############################################################################
823# command handling &c 1021# command handling &c
824 1022
825=item cf::register_command $name => \&callback($ob,$args); 1023=item cf::register_command $name => \&callback($ob,$args);
838 push @{ $COMMAND{$name} }, [$caller, $cb]; 1036 push @{ $COMMAND{$name} }, [$caller, $cb];
839} 1037}
840 1038
841=item cf::register_extcmd $name => \&callback($pl,$packet); 1039=item cf::register_extcmd $name => \&callback($pl,$packet);
842 1040
843Register a callbackf ro execution when the client sends an extcmd packet. 1041Register a callback for execution when the client sends an (synchronous)
1042extcmd packet. Ext commands will be processed in the order they are
1043received by the server, like other user commands. The first argument is
1044the logged-in player. Ext commands can only be processed after a player
1045has logged in successfully.
844 1046
845If the callback returns something, it is sent back as if reply was being 1047If the callback returns something, it is sent back as if reply was being
846called. 1048called.
847 1049
1050=item cf::register_exticmd $name => \&callback($ns,$packet);
1051
1052Register a callback for execution when the client sends an (asynchronous)
1053exticmd packet. Exti commands are processed by the server as soon as they
1054are received, i.e. out of order w.r.t. other commands. The first argument
1055is a client socket. Exti commands can be received anytime, even before
1056log-in.
1057
1058If the callback returns something, it is sent back as if reply was being
1059called.
1060
848=cut 1061=cut
849 1062
850sub register_extcmd { 1063sub register_extcmd {
851 my ($name, $cb) = @_; 1064 my ($name, $cb) = @_;
852 1065
853 $EXTCMD{$name} = $cb; 1066 $EXTCMD{$name} = $cb;
1067}
1068
1069sub register_exticmd {
1070 my ($name, $cb) = @_;
1071
1072 $EXTICMD{$name} = $cb;
854} 1073}
855 1074
856cf::player->attach ( 1075cf::player->attach (
857 on_command => sub { 1076 on_command => sub {
858 my ($pl, $name, $params) = @_; 1077 my ($pl, $name, $params) = @_;
883 1102
884 cf::override; 1103 cf::override;
885 }, 1104 },
886); 1105);
887 1106
888sub load_extension {
889 my ($path) = @_;
890
891 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
892 my $base = $1;
893 my $pkg = $1;
894 $pkg =~ s/[^[:word:]]/_/g;
895 $pkg = "ext::$pkg";
896
897 warn "... loading '$path' into '$pkg'\n";
898
899 open my $fh, "<:utf8", $path
900 or die "$path: $!";
901
902 my $source =
903 "package $pkg; use strict; use utf8;\n"
904 . "#line 1 \"$path\"\n{\n"
905 . (do { local $/; <$fh> })
906 . "\n};\n1";
907
908 unless (eval $source) {
909 my $msg = $@ ? "$path: $@\n"
910 : "extension disabled.\n";
911 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
912 warn $@;
913 warn "mandatory extension failed to load, exiting.\n";
914 exit 1;
915 }
916 die $@;
917 }
918
919 push @EXTS, $pkg;
920}
921
922sub load_extensions { 1107sub load_extensions {
1108 cf::sync_job {
1109 my %todo;
1110
923 for my $ext (<$LIBDIR/*.ext>) { 1111 for my $path (<$LIBDIR/*.ext>) {
924 next unless -r $ext; 1112 next unless -r $path;
925 eval { 1113
926 load_extension $ext; 1114 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1115 my $base = $1;
1116 my $pkg = $1;
1117 $pkg =~ s/[^[:word:]]/_/g;
1118 $pkg = "ext::$pkg";
1119
1120 open my $fh, "<:utf8", $path
1121 or die "$path: $!";
1122
1123 my $source = do { local $/; <$fh> };
1124
1125 my %ext = (
1126 path => $path,
1127 base => $base,
1128 pkg => $pkg,
1129 );
1130
1131 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1132 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1133
1134 $ext{source} =
1135 "package $pkg; use strict; use utf8;\n"
1136 . "#line 1 \"$path\"\n{\n"
1137 . $source
1138 . "\n};\n1";
1139
1140 $todo{$base} = \%ext;
1141 }
1142
1143 my %done;
1144 while (%todo) {
1145 my $progress;
1146
1147 while (my ($k, $v) = each %todo) {
1148 for (split /,\s*/, $v->{meta}{depends}) {
1149 goto skip
1150 unless exists $done{$_};
1151 }
1152
1153 warn "... loading '$k' into '$v->{pkg}'\n";
1154
1155 unless (eval $v->{source}) {
1156 my $msg = $@ ? "$v->{path}: $@\n"
1157 : "$v->{base}: extension inactive.\n";
1158
1159 if (exists $v->{meta}{mandatory}) {
1160 warn $msg;
1161 warn "mandatory extension failed to load, exiting.\n";
1162 exit 1;
1163 }
1164
1165 warn $msg;
1166 }
1167
1168 $done{$k} = delete $todo{$k};
1169 push @EXTS, $v->{pkg};
1170 $progress = 1;
927 1 1171 }
928 } or warn "$ext not loaded: $@"; 1172
1173 skip:
1174 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1175 unless $progress;
1176 }
929 } 1177 };
930} 1178}
931 1179
932############################################################################# 1180#############################################################################
933 1181
1182=back
1183
934=head2 CORE EXTENSIONS 1184=head2 CORE EXTENSIONS
935 1185
936Functions and methods that extend core crossfire objects. 1186Functions and methods that extend core crossfire objects.
937 1187
938=cut 1188=cut
950Returns the given player object, loading it if necessary (might block). 1200Returns the given player object, loading it if necessary (might block).
951 1201
952=cut 1202=cut
953 1203
954sub playerdir($) { 1204sub playerdir($) {
955 cf::localdir 1205 "$PLAYERDIR/"
956 . "/"
957 . cf::playerdir
958 . "/"
959 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1206 . (ref $_[0] ? $_[0]->ob->name : $_[0])
960} 1207}
961 1208
962sub path($) { 1209sub path($) {
963 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1210 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
964 1211
965 (playerdir $login) . "/$login.pl" 1212 (playerdir $login) . "/playerdata"
966} 1213}
967 1214
968sub find_active($) { 1215sub find_active($) {
969 $cf::PLAYER{$_[0]} 1216 $cf::PLAYER{$_[0]}
970 and $cf::PLAYER{$_[0]}->active 1217 and $cf::PLAYER{$_[0]}->active
983 my $login = $_[0]; 1230 my $login = $_[0];
984 1231
985 my $guard = cf::lock_acquire "user_find:$login"; 1232 my $guard = cf::lock_acquire "user_find:$login";
986 1233
987 $cf::PLAYER{$_[0]} || do { 1234 $cf::PLAYER{$_[0]} || do {
1235 # rename old playerfiles to new ones
1236 #TODO: remove when no longer required
1237 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1238 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1239 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1240 aio_unlink +(playerdir $login) . "/$login.pl";
1241
988 my $pl = load_pl path $login 1242 my $pl = load_pl path $login
989 or return; 1243 or return;
990 $cf::PLAYER{$login} = $pl 1244 $cf::PLAYER{$login} = $pl
991 } 1245 }
992 } 1246 }
1029 1283
1030=cut 1284=cut
1031 1285
1032sub quit_character { 1286sub quit_character {
1033 my ($pl) = @_; 1287 my ($pl) = @_;
1288
1289 my $name = $pl->ob->name;
1034 1290
1035 $pl->{deny_save} = 1; 1291 $pl->{deny_save} = 1;
1036 $pl->password ("*"); # this should lock out the player until we nuked the dir 1292 $pl->password ("*"); # this should lock out the player until we nuked the dir
1037 1293
1038 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1294 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1043 my $path = playerdir $pl; 1299 my $path = playerdir $pl;
1044 my $temp = "$path~$cf::RUNTIME~deleting~"; 1300 my $temp = "$path~$cf::RUNTIME~deleting~";
1045 aio_rename $path, $temp; 1301 aio_rename $path, $temp;
1046 delete $cf::PLAYER{$pl->ob->name}; 1302 delete $cf::PLAYER{$pl->ob->name};
1047 $pl->destroy; 1303 $pl->destroy;
1304
1305 my $prefix = qr<^~\Q$name\E/>;
1306
1307 # nuke player maps
1308 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1309
1048 IO::AIO::aio_rmtree $temp; 1310 IO::AIO::aio_rmtree $temp;
1311}
1312
1313=item $pl->kick
1314
1315Kicks a player out of the game. This destroys the connection.
1316
1317=cut
1318
1319sub kick {
1320 my ($pl, $kicker) = @_;
1321
1322 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1323 $pl->killer ("kicked");
1324 $pl->ns->destroy;
1049} 1325}
1050 1326
1051=item cf::player::list_logins 1327=item cf::player::list_logins
1052 1328
1053Returns am arrayref of all valid playernames in the system, can take a 1329Returns am arrayref of all valid playernames in the system, can take a
1054while and may block, so not sync_job-capable, ever. 1330while and may block, so not sync_job-capable, ever.
1055 1331
1056=cut 1332=cut
1057 1333
1058sub list_logins { 1334sub list_logins {
1059 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1335 my $dirs = aio_readdir $PLAYERDIR
1060 or return []; 1336 or return [];
1061 1337
1062 my @logins; 1338 my @logins;
1063 1339
1064 for my $login (@$dirs) { 1340 for my $login (@$dirs) {
1099 } 1375 }
1100 1376
1101 \@paths 1377 \@paths
1102} 1378}
1103 1379
1380=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1381
1382Expand crossfire pod fragments into protocol xml.
1383
1384=cut
1385
1386sub expand_cfpod {
1387 ((my $self), (local $_)) = @_;
1388
1389 # escape & and <
1390 s/&/&amp;/g;
1391 s/(?<![BIUGH])</&lt;/g;
1392
1393 # this is buggy, it needs to properly take care of nested <'s
1394
1395 1 while
1396 # replace B<>, I<>, U<> etc.
1397 s/B<([^\>]*)>/<b>$1<\/b>/
1398 || s/I<([^\>]*)>/<i>$1<\/i>/
1399 || s/U<([^\>]*)>/<u>$1<\/u>/
1400 # replace G<male|female> tags
1401 || s{G<([^>|]*)\|([^>]*)>}{
1402 $self->gender ? $2 : $1
1403 }ge
1404 # replace H<hint text>
1405 || s/H<([^\>]*)>/<fg name="lightblue">[$1]<\/fg>/g;
1406
1407 # create single paragraphs (very hackish)
1408 s/(?<=\S)\n(?=\w)/ /g;
1409
1410 $_
1411}
1412
1104=item $player->ext_reply ($msgid, $msgtype, %msg) 1413=item $player->ext_reply ($msgid, %msg)
1105 1414
1106Sends an ext reply to the player. 1415Sends an ext reply to the player.
1107 1416
1108=cut 1417=cut
1109 1418
1110sub ext_reply($$$%) { 1419sub ext_reply($$%) {
1111 my ($self, $id, %msg) = @_; 1420 my ($self, $id, %msg) = @_;
1112 1421
1113 $msg{msgid} = $id; 1422 $msg{msgid} = $id;
1114
1115 $self->send ("ext " . cf::to_json \%msg); 1423 $self->send ("ext " . cf::to_json \%msg);
1116} 1424}
1117 1425
1118package cf; 1426=item $player->ext_event ($type, %msg)
1427
1428Sends an ext event to the client.
1429
1430=cut
1431
1432sub ext_event($$%) {
1433 my ($self, $type, %msg) = @_;
1434
1435 $self->ns->ext_event ($type, %msg);
1436}
1437
1438=head3 cf::region
1439
1440=over 4
1441
1442=cut
1443
1444package cf::region;
1445
1446=item cf::region::find_by_path $path
1447
1448Tries to decuce the likely region for a map knowing only its path.
1449
1450=cut
1451
1452sub find_by_path($) {
1453 my ($path) = @_;
1454
1455 my ($match, $specificity);
1456
1457 for my $region (list) {
1458 if ($region->match && $path =~ $region->match) {
1459 ($match, $specificity) = ($region, $region->specificity)
1460 if $region->specificity > $specificity;
1461 }
1462 }
1463
1464 $match
1465}
1119 1466
1120=back 1467=back
1121
1122 1468
1123=head3 cf::map 1469=head3 cf::map
1124 1470
1125=over 4 1471=over 4
1126 1472
1181 my ($self, $merge) = @_; 1527 my ($self, $merge) = @_;
1182 1528
1183 # we have to keep some variables in memory intact 1529 # we have to keep some variables in memory intact
1184 local $self->{path}; 1530 local $self->{path};
1185 local $self->{load_path}; 1531 local $self->{load_path};
1186 local $self->{deny_save};
1187 local $self->{deny_reset};
1188 1532
1189 $self->SUPER::thawer_merge ($merge); 1533 $self->SUPER::thawer_merge ($merge);
1190} 1534}
1191 1535
1192sub normalise { 1536sub normalise {
1264 1608
1265# the original (read-only) location 1609# the original (read-only) location
1266sub load_path { 1610sub load_path {
1267 my ($self) = @_; 1611 my ($self) = @_;
1268 1612
1269 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path} 1613 "$MAPDIR/$self->{path}.map"
1270} 1614}
1271 1615
1272# the temporary/swap location 1616# the temporary/swap location
1273sub save_path { 1617sub save_path {
1274 my ($self) = @_; 1618 my ($self) = @_;
1275 1619
1276 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1620 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1277 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path 1621 "$TMPDIR/$path.map"
1278} 1622}
1279 1623
1280# the unique path, undef == no special unique path 1624# the unique path, undef == no special unique path
1281sub uniq_path { 1625sub uniq_path {
1282 my ($self) = @_; 1626 my ($self) = @_;
1283 1627
1284 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1628 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1285 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1629 "$UNIQUEDIR/$path"
1286} 1630}
1287 1631
1288# and all this just because we cannot iterate over 1632# and all this just because we cannot iterate over
1289# all maps in C++... 1633# all maps in C++...
1290sub change_all_map_light { 1634sub change_all_map_light {
1291 my ($change) = @_; 1635 my ($change) = @_;
1292 1636
1293 $_->change_map_light ($change) 1637 $_->change_map_light ($change)
1294 for grep $_->outdoor, values %cf::MAP; 1638 for grep $_->outdoor, values %cf::MAP;
1639}
1640
1641sub decay_objects {
1642 my ($self) = @_;
1643
1644 return if $self->{deny_reset};
1645
1646 $self->do_decay_objects;
1295} 1647}
1296 1648
1297sub unlink_save { 1649sub unlink_save {
1298 my ($self) = @_; 1650 my ($self) = @_;
1299 1651
1357 $self->load_header_orig 1709 $self->load_header_orig
1358 or return; 1710 or return;
1359 $self->prepare_orig; 1711 $self->prepare_orig;
1360 } 1712 }
1361 1713
1714 $self->{deny_reset} = 1
1715 if $self->no_reset;
1716
1717 $self->default_region (cf::region::find_by_path $self->{path})
1718 unless $self->default_region;
1719
1362 1 1720 1
1363} 1721}
1364 1722
1365sub find; 1723sub find;
1366sub find { 1724sub find {
1378 $map->{last_save} = $cf::RUNTIME; 1736 $map->{last_save} = $cf::RUNTIME;
1379 1737
1380 $map->load_header 1738 $map->load_header
1381 or return; 1739 or return;
1382 1740
1383 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1741 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1384 # doing this can freeze the server in a sync job, obviously 1742 # doing this can freeze the server in a sync job, obviously
1385 #$cf::WAIT_FOR_TICK->wait; 1743 #$cf::WAIT_FOR_TICK->wait;
1386 $map->reset; 1744 $map->reset;
1387 undef $guard; 1745 undef $guard;
1388 return find $path; 1746 return find $path;
1399 my ($self) = @_; 1757 my ($self) = @_;
1400 1758
1401 local $self->{deny_reset} = 1; # loading can take a long time 1759 local $self->{deny_reset} = 1; # loading can take a long time
1402 1760
1403 my $path = $self->{path}; 1761 my $path = $self->{path};
1762
1763 {
1404 my $guard = cf::lock_acquire "map_load:$path"; 1764 my $guard = cf::lock_acquire "map_load:$path";
1405 1765
1406 return if $self->in_memory != cf::MAP_SWAPPED; 1766 return if $self->in_memory != cf::MAP_SWAPPED;
1407 1767
1408 $self->in_memory (cf::MAP_LOADING); 1768 $self->in_memory (cf::MAP_LOADING);
1409 1769
1410 $self->alloc; 1770 $self->alloc;
1411 1771
1412 $self->pre_load; 1772 $self->pre_load;
1413
1414 $self->_load_objects ($self->{load_path}, 1)
1415 or return;
1416
1417 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1418 if delete $self->{load_original};
1419
1420 if (my $uniq = $self->uniq_path) {
1421 utf8::encode $uniq;
1422 if (aio_open $uniq, O_RDONLY, 0) {
1423 $self->clear_unique_items;
1424 $self->_load_objects ($uniq, 0);
1425 }
1426 }
1427
1428 Coro::cede;
1429
1430 # now do the right thing for maps
1431 $self->link_multipart_objects;
1432
1433 unless ($self->{deny_activate}) {
1434 $self->decay_objects;
1435 $self->fix_auto_apply;
1436 $self->update_buttons;
1437 Coro::cede; 1773 Coro::cede;
1438 $self->set_darkness_map; 1774
1775 $self->_load_objects ($self->{load_path}, 1)
1776 or return;
1777
1778 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1779 if delete $self->{load_original};
1780
1781 if (my $uniq = $self->uniq_path) {
1782 utf8::encode $uniq;
1783 if (aio_open $uniq, O_RDONLY, 0) {
1784 $self->clear_unique_items;
1785 $self->_load_objects ($uniq, 0);
1786 }
1787 }
1788
1789 Coro::cede;
1790 # now do the right thing for maps
1791 $self->link_multipart_objects;
1439 $self->difficulty ($self->estimate_difficulty) 1792 $self->difficulty ($self->estimate_difficulty)
1440 unless $self->difficulty; 1793 unless $self->difficulty;
1441 Coro::cede; 1794 Coro::cede;
1795
1796 unless ($self->{deny_activate}) {
1797 $self->decay_objects;
1798 $self->fix_auto_apply;
1799 $self->update_buttons;
1800 Coro::cede;
1801 $self->set_darkness_map;
1802 Coro::cede;
1442 $self->activate; 1803 $self->activate;
1804 }
1805
1806 $self->in_memory (cf::MAP_IN_MEMORY);
1443 } 1807 }
1444 1808
1445 $self->post_load; 1809 $self->post_load;
1446
1447 $self->in_memory (cf::MAP_IN_MEMORY);
1448} 1810}
1449 1811
1450sub customise_for { 1812sub customise_for {
1451 my ($self, $ob) = @_; 1813 my ($self, $ob) = @_;
1452 1814
1453 return find "~" . $ob->name . "/" . $self->{path} 1815 return find "~" . $ob->name . "/" . $self->{path}
1454 if $self->per_player; 1816 if $self->per_player;
1817
1818# return find "?party/" . $ob->name . "/" . $self->{path}
1819# if $self->per_party;
1455 1820
1456 $self 1821 $self
1457} 1822}
1458 1823
1459# find and load all maps in the 3x3 area around a map 1824# find and load all maps in the 3x3 area around a map
1570 1935
1571sub reset_at { 1936sub reset_at {
1572 my ($self) = @_; 1937 my ($self) = @_;
1573 1938
1574 # TODO: safety, remove and allow resettable per-player maps 1939 # TODO: safety, remove and allow resettable per-player maps
1575 return 1e99 if $self->isa ("ext::map_per_player");#d#
1576 return 1e99 if $self->{deny_reset}; 1940 return 1e99 if $self->{deny_reset};
1577 1941
1578 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1942 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1579 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1943 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1580 1944
1591 my ($self) = @_; 1955 my ($self) = @_;
1592 1956
1593 my $lock = cf::lock_acquire "map_data:$self->{path}"; 1957 my $lock = cf::lock_acquire "map_data:$self->{path}";
1594 1958
1595 return if $self->players; 1959 return if $self->players;
1596 return if $self->isa ("ext::map_per_player");#d#
1597 1960
1598 warn "resetting map ", $self->path;#d# 1961 warn "resetting map ", $self->path;
1599 1962
1600 $self->in_memory (cf::MAP_SWAPPED); 1963 $self->in_memory (cf::MAP_SWAPPED);
1601 1964
1602 # need to save uniques path 1965 # need to save uniques path
1603 unless ($self->{deny_save}) { 1966 unless ($self->{deny_save}) {
1635 $cf::MAP{$self->path} = $self; 1998 $cf::MAP{$self->path} = $self;
1636 1999
1637 $self->reset; # polite request, might not happen 2000 $self->reset; # polite request, might not happen
1638} 2001}
1639 2002
2003=item $maps = cf::map::tmp_maps
2004
2005Returns an arrayref with all map paths of currently instantiated and saved
2006maps. May block.
2007
2008=cut
2009
2010sub tmp_maps() {
2011 [
2012 map {
2013 utf8::decode $_;
2014 /\.map$/
2015 ? normalise $_
2016 : ()
2017 } @{ aio_readdir $TMPDIR or [] }
2018 ]
2019}
2020
2021=item $maps = cf::map::random_maps
2022
2023Returns an arrayref with all map paths of currently instantiated and saved
2024random maps. May block.
2025
2026=cut
2027
2028sub random_maps() {
2029 [
2030 map {
2031 utf8::decode $_;
2032 /\.map$/
2033 ? normalise "?random/$_"
2034 : ()
2035 } @{ aio_readdir $RANDOMDIR or [] }
2036 ]
2037}
2038
1640=item cf::map::unique_maps 2039=item cf::map::unique_maps
1641 2040
1642Returns an arrayref of paths of all shared maps that have 2041Returns an arrayref of paths of all shared maps that have
1643instantiated unique items. May block. 2042instantiated unique items. May block.
1644 2043
1645=cut 2044=cut
1646 2045
1647sub unique_maps() { 2046sub unique_maps() {
1648 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2047 [
1649 or return; 2048 map {
1650
1651 my @paths;
1652
1653 for (@$files) {
1654 utf8::decode $_; 2049 utf8::decode $_;
1655 next if /\.pst$/; 2050 /\.map$/
1656 next unless /^$PATH_SEP/o; 2051 ? normalise $_
1657 2052 : ()
1658 push @paths, cf::map::normalise $_; 2053 } @{ aio_readdir $UNIQUEDIR or [] }
1659 } 2054 ]
1660
1661 \@paths
1662} 2055}
1663 2056
1664package cf; 2057package cf;
1665 2058
1666=back 2059=back
1712 2105
1713 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2106 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1714 2107
1715 if ($self->{record_replies}) { 2108 if ($self->{record_replies}) {
1716 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2109 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2110
1717 } else { 2111 } else {
2112 my $pl = $self->contr;
2113
2114 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2115 my $diag = $pl->{npc_dialog};
2116 $diag->{pl}->ext_reply (
2117 $diag->{id},
2118 msgtype => "reply",
2119 msg => $diag->{pl}->expand_cfpod ($msg),
2120 add_topics => []
2121 );
2122
2123 } else {
1718 $msg = $npc->name . " says: $msg" if $npc; 2124 $msg = $npc->name . " says: $msg" if $npc;
1719 $self->message ($msg, $flags); 2125 $self->message ($msg, $flags);
2126 }
1720 } 2127 }
1721} 2128}
1722 2129
1723=item $player_object->may ("access") 2130=item $player_object->may ("access")
1724 2131
1772 $self->deactivate_recursive; 2179 $self->deactivate_recursive;
1773 2180
1774 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2181 return if UNIVERSAL::isa $self->map, "ext::map_link";
1775 2182
1776 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2183 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1777 if $self->map; 2184 if $self->map && $self->map->{path} ne "{link}";
1778 2185
1779 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2186 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1780} 2187}
1781 2188
1782sub cf::object::player::leave_link { 2189sub cf::object::player::leave_link {
1783 my ($self, $map, $x, $y) = @_; 2190 my ($self, $map, $x, $y) = @_;
2191
2192 return unless $self->contr->active;
1784 2193
1785 my $link_pos = delete $self->{_link_pos}; 2194 my $link_pos = delete $self->{_link_pos};
1786 2195
1787 unless ($map) { 2196 unless ($map) {
1788 # restore original map position 2197 # restore original map position
1811 2220
1812 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2221 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1813 $self->enter_map ($map, $x, $y); 2222 $self->enter_map ($map, $x, $y);
1814} 2223}
1815 2224
1816cf::player->attach (
1817 on_logout => sub {
1818 my ($pl) = @_;
1819
1820 # abort map switching before logout
1821 if ($pl->ob->{_link_pos}) {
1822 cf::sync_job {
1823 $pl->ob->leave_link
1824 };
1825 }
1826 },
1827 on_login => sub {
1828 my ($pl) = @_;
1829
1830 # try to abort aborted map switching on player login :)
1831 # should happen only on crashes
1832 if ($pl->ob->{_link_pos}) {
1833 $pl->ob->enter_link;
1834 (async {
1835 $pl->ob->reply (undef,
1836 "There was an internal problem at your last logout, "
1837 . "the server will try to bring you to your intended destination in a second.",
1838 cf::NDI_RED);
1839 # we need this sleep as the login has a concurrent enter_exit running
1840 # and this sleep increases chances of the player not ending up in scorn
1841 Coro::Timer::sleep 1;
1842 $pl->ob->leave_link;
1843 })->prio (2);
1844 }
1845 },
1846);
1847
1848=item $player_object->goto ($path, $x, $y) 2225=item $player_object->goto ($path, $x, $y[, $check->($map)])
1849 2226
2227Moves the player to the given map-path and coordinates by first freezing
2228her, loading and preparing them map, calling the provided $check callback
2229that has to return the map if sucecssful, and then unfreezes the player on
2230the new (success) or old (failed) map position.
2231
1850=cut 2232=cut
2233
2234our $GOTOGEN;
1851 2235
1852sub cf::object::player::goto { 2236sub cf::object::player::goto {
1853 my ($self, $path, $x, $y) = @_; 2237 my ($self, $path, $x, $y, $check) = @_;
2238
2239 # do generation counting so two concurrent goto's will be executed in-order
2240 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1854 2241
1855 $self->enter_link; 2242 $self->enter_link;
1856 2243
1857 (async { 2244 (async {
1858 my $map = eval { 2245 my $map = eval {
1859 my $map = cf::map::find $path; 2246 my $map = cf::map::find $path;
2247
2248 if ($map) {
1860 $map = $map->customise_for ($self) if $map; 2249 $map = $map->customise_for ($self);
2250 $map = $check->($map) if $check && $map;
2251 } else {
2252 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2253 }
2254
1861 $map 2255 $map
2256 };
2257
2258 if ($@) {
2259 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2260 LOG llevError | logBacktrace, Carp::longmess $@;
1862 } or 2261 }
1863 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1864 2262
2263 if ($gen == $self->{_goto_generation}) {
2264 delete $self->{_goto_generation};
1865 $self->leave_link ($map, $x, $y); 2265 $self->leave_link ($map, $x, $y);
2266 }
1866 })->prio (1); 2267 })->prio (1);
1867} 2268}
1868 2269
1869=item $player_object->enter_exit ($exit_object) 2270=item $player_object->enter_exit ($exit_object)
1870 2271
1909 2310
1910 $rmp->{random_seed} ||= $exit->random_seed; 2311 $rmp->{random_seed} ||= $exit->random_seed;
1911 2312
1912 my $data = cf::to_json $rmp; 2313 my $data = cf::to_json $rmp;
1913 my $md5 = Digest::MD5::md5_hex $data; 2314 my $md5 = Digest::MD5::md5_hex $data;
1914 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2315 my $meta = "$RANDOMDIR/$md5.meta";
1915 2316
1916 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2317 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1917 aio_write $fh, 0, (length $data), $data, 0; 2318 aio_write $fh, 0, (length $data), $data, 0;
1918 undef $fh; 2319 undef $fh;
1919 aio_rename "$meta~", $meta; 2320 aio_rename "$meta~", $meta;
1928 2329
1929 return unless $self->type == cf::PLAYER; 2330 return unless $self->type == cf::PLAYER;
1930 2331
1931 if ($exit->slaying eq "/!") { 2332 if ($exit->slaying eq "/!") {
1932 #TODO: this should de-fi-ni-te-ly not be a sync-job 2333 #TODO: this should de-fi-ni-te-ly not be a sync-job
2334 # the problem is that $exit might not survive long enough
2335 # so it needs to be done right now, right here
1933 cf::sync_job { prepare_random_map $exit }; 2336 cf::sync_job { prepare_random_map $exit };
1934 } 2337 }
1935 2338
1936 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2339 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1937 my $hp = $exit->stats->hp; 2340 my $hp = $exit->stats->hp;
1945 $self->goto ($slaying, $hp, $sp); 2348 $self->goto ($slaying, $hp, $sp);
1946 2349
1947 1; 2350 1;
1948 }) { 2351 }) {
1949 $self->message ("Something went wrong deep within the crossfire server. " 2352 $self->message ("Something went wrong deep within the crossfire server. "
1950 . "I'll try to bring you back to the map you were before. " 2353 . "I'll try to bring you back to the map you were before. "
1951 . "Please report this to the dungeon master!", 2354 . "Please report this to the dungeon master!",
1952 cf::NDI_UNIQUE | cf::NDI_RED); 2355 cf::NDI_UNIQUE | cf::NDI_RED);
1953 2356
1954 warn "ERROR in enter_exit: $@"; 2357 warn "ERROR in enter_exit: $@";
1955 $self->leave_link; 2358 $self->leave_link;
1956 } 2359 }
1957 })->prio (1); 2360 })->prio (1);
1970 2373
1971sub cf::client::send_drawinfo { 2374sub cf::client::send_drawinfo {
1972 my ($self, $text, $flags) = @_; 2375 my ($self, $text, $flags) = @_;
1973 2376
1974 utf8::encode $text; 2377 utf8::encode $text;
1975 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2378 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1976} 2379}
1977 2380
2381=item $client->send_msg ($color, $type, $msg, [extra...])
2382
2383Send a drawinfo or msg packet to the client, formatting the msg for the
2384client if neccessary. C<$type> should be a string identifying the type of
2385the message, with C<log> being the default. If C<$color> is negative, suppress
2386the message unless the client supports the msg packet.
2387
2388=cut
2389
2390sub cf::client::send_msg {
2391 my ($self, $color, $type, $msg, @extra) = @_;
2392
2393 $msg = $self->pl->expand_cfpod ($msg);
2394
2395 if ($self->can_msg) {
2396 $self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]);
2397 } else {
2398 # replace some tags by gcfclient-compatible ones
2399 for ($msg) {
2400 1 while
2401 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2402 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2403 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2404 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2405 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2406 }
2407
2408 if ($color >= 0) {
2409 if (0 && $msg =~ /\[/) {
2410 $self->send_packet ("drawextinfo $color 4 0 $msg")
2411 } else {
2412 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2413 $self->send_packet ("drawinfo $color $msg")
2414 }
2415 }
2416 }
2417}
2418
2419=item $client->ext_event ($type, %msg)
2420
2421Sends an ext event to the client.
2422
2423=cut
2424
2425sub cf::client::ext_event($$%) {
2426 my ($self, $type, %msg) = @_;
2427
2428 $msg{msgtype} = "event_$type";
2429 $self->send_packet ("ext " . cf::to_json \%msg);
2430}
1978 2431
1979=item $success = $client->query ($flags, "text", \&cb) 2432=item $success = $client->query ($flags, "text", \&cb)
1980 2433
1981Queues a query to the client, calling the given callback with 2434Queues a query to the client, calling the given callback with
1982the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2435the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1983C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2436C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1984 2437
1985Queries can fail, so check the return code. Or don't, as queries will become 2438Queries can fail, so check the return code. Or don't, as queries will
1986reliable at some point in the future. 2439become reliable at some point in the future.
1987 2440
1988=cut 2441=cut
1989 2442
1990sub cf::client::query { 2443sub cf::client::query {
1991 my ($self, $flags, $text, $cb) = @_; 2444 my ($self, $flags, $text, $cb) = @_;
1999 utf8::encode $text; 2452 utf8::encode $text;
2000 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2453 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2001 2454
2002 $self->send_packet ($self->{query_queue}[0][0]) 2455 $self->send_packet ($self->{query_queue}[0][0])
2003 if @{ $self->{query_queue} } == 1; 2456 if @{ $self->{query_queue} } == 1;
2457
2458 1
2004} 2459}
2005 2460
2006cf::client->attach ( 2461cf::client->attach (
2007 on_reply => sub { 2462 on_reply => sub {
2008 my ($ns, $msg) = @_; 2463 my ($ns, $msg) = @_;
2023 } else { 2478 } else {
2024 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2479 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2025 } 2480 }
2026 } 2481 }
2027 }, 2482 },
2483 on_exticmd => sub {
2484 my ($ns, $buf) = @_;
2485
2486 my $msg = eval { from_json $buf };
2487
2488 if (ref $msg) {
2489 if (my $cb = $EXTICMD{$msg->{msgtype}}) {
2490 if (my %reply = $cb->($ns, $msg)) {
2491 $reply{msgid} = $msg->{msgid};
2492 $ns->send ("ext " . cf::to_json \%reply);
2493 }
2494 }
2495 } else {
2496 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2497 }
2498
2499 cf::override;
2500 },
2028); 2501);
2029 2502
2030=item $client->async (\&cb) 2503=item $client->async (\&cb)
2031 2504
2032Create a new coroutine, running the specified callback. The coroutine will 2505Create a new coroutine, running the specified callback. The coroutine will
2079 2552
2080# here we export the classes and methods available to script code 2553# here we export the classes and methods available to script code
2081 2554
2082=pod 2555=pod
2083 2556
2084The following fucntions and emthods are available within a safe environment: 2557The following functions and methods are available within a safe environment:
2085 2558
2086 cf::object contr pay_amount pay_player map 2559 cf::object contr pay_amount pay_player map
2087 cf::object::player player 2560 cf::object::player player
2088 cf::player peaceful 2561 cf::player peaceful
2089 cf::map trigger 2562 cf::map trigger
2170=back 2643=back
2171 2644
2172=cut 2645=cut
2173 2646
2174############################################################################# 2647#############################################################################
2175
2176=head2 EXTENSION DATABASE SUPPORT
2177
2178Crossfire maintains a very simple database for extension use. It can
2179currently store anything that can be serialised using Storable, which
2180excludes objects.
2181
2182The parameter C<$family> should best start with the name of the extension
2183using it, it should be unique.
2184
2185=over 4
2186
2187=item $value = cf::db_get $family => $key
2188
2189Returns a single value from the database.
2190
2191=item cf::db_put $family => $key => $value
2192
2193Stores the given C<$value> in the family.
2194
2195=cut
2196
2197our $DB;
2198
2199sub db_init {
2200 unless ($DB) {
2201 $DB = BDB::db_create $DB_ENV;
2202
2203 cf::sync_job {
2204 eval {
2205 $DB->set_flags (BDB::CHKSUM);
2206
2207 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2208 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2209 cf::cleanup "db_open(db): $!" if $!;
2210 };
2211 cf::cleanup "db_open(db): $@" if $@;
2212 };
2213
2214 my $path = cf::localdir . "/database.pst";
2215 if (stat $path) {
2216 cf::sync_job {
2217 my $pst = Storable::retrieve $path;
2218
2219 cf::db_put (board => data => $pst->{board});
2220 cf::db_put (guildrules => data => $pst->{guildrules});
2221 cf::db_put (rent => balance => $pst->{rent}{balance});
2222 BDB::db_env_txn_checkpoint $DB_ENV;
2223
2224 unlink $path;
2225 };
2226 }
2227 }
2228}
2229
2230sub db_get($$) {
2231 my $key = "$_[0]/$_[1]";
2232
2233 cf::sync_job {
2234 BDB::db_get $DB, undef, $key, my $data;
2235
2236 $! ? ()
2237 : Compress::LZF::sthaw $data
2238 }
2239}
2240
2241sub db_put($$$) {
2242 BDB::dbreq_pri 4;
2243 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
2244}
2245
2246#############################################################################
2247# the server's init and main functions 2648# the server's init and main functions
2248 2649
2249sub init_resources { 2650sub load_facedata($) {
2250 load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir 2651 my ($path) = @_;
2652
2653 warn "loading facedata from $path\n";
2654
2655 my $facedata;
2656 0 < aio_load $path, $facedata
2657 or die "$path: $!";
2658
2659 $facedata = Coro::Storable::thaw $facedata;
2660
2661 $facedata->{version} == 2
2662 or cf::cleanup "$path: version mismatch, cannot proceed.";
2663
2664 {
2665 my $faces = $facedata->{faceinfo};
2666
2667 while (my ($face, $info) = each %$faces) {
2668 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2669 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2670 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2671 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2672 Coro::cede;
2673 }
2674
2675 while (my ($face, $info) = each %$faces) {
2676 next unless $info->{smooth};
2677 my $idx = cf::face::find $face
2678 or next;
2679 if (my $smooth = cf::face::find $info->{smooth}) {
2680 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2681 } else {
2682 warn "smooth face '$info->{smooth}' not found for face '$face'";
2683 }
2684 Coro::cede;
2685 }
2686 }
2687
2688 {
2689 my $anims = $facedata->{animinfo};
2690
2691 while (my ($anim, $info) = each %$anims) {
2692 cf::anim::set $anim, $info->{frames}, $info->{facings};
2693 Coro::cede;
2694 }
2695
2696 cf::anim::invalidate_all; # d'oh
2697 }
2698
2699 1
2700}
2701
2702sub reload_regions {
2703 load_resource_file "$MAPDIR/regions"
2251 or die "unable to load regions file\n";#d# 2704 or die "unable to load regions file\n";
2705}
2706
2707sub reload_facedata {
2708 load_facedata "$DATADIR/facedata"
2709 or die "unable to load facedata\n";
2710}
2711
2712sub reload_archetypes {
2713 load_resource_file "$DATADIR/archetypes"
2714 or die "unable to load archetypes\n";
2715}
2716
2717sub reload_treasures {
2718 load_resource_file "$DATADIR/treasures"
2719 or die "unable to load treasurelists\n";
2720}
2721
2722sub reload_resources {
2723 warn "reloading resource files...\n";
2724
2725 reload_regions;
2726 reload_facedata;
2727 #reload_archetypes;#d#
2728 reload_archetypes;
2729 reload_treasures;
2730
2731 warn "finished reloading resource files\n";
2732}
2733
2734sub init {
2735 reload_resources;
2252} 2736}
2253 2737
2254sub cfg_load { 2738sub cfg_load {
2255 open my $fh, "<:utf8", cf::confdir . "/config" 2739 open my $fh, "<:utf8", "$CONFDIR/config"
2256 or return; 2740 or return;
2257 2741
2258 local $/; 2742 local $/;
2259 *CFG = YAML::Syck::Load <$fh>; 2743 *CFG = YAML::Syck::Load <$fh>;
2260 2744
2268 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 2752 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2269 and die "WARNING: m(un)lockall failed: $!\n"; 2753 and die "WARNING: m(un)lockall failed: $!\n";
2270 }; 2754 };
2271 warn $@ if $@; 2755 warn $@ if $@;
2272 } 2756 }
2273}
2274
2275sub init {
2276 init_resources;
2277} 2757}
2278 2758
2279sub main { 2759sub main {
2280 # we must not ever block the main coroutine 2760 # we must not ever block the main coroutine
2281 local $Coro::idle = sub { 2761 local $Coro::idle = sub {
2309 }, 2789 },
2310 ); 2790 );
2311 } 2791 }
2312} 2792}
2313 2793
2794sub write_runtime {
2795 my $runtime = "$LOCALDIR/runtime";
2796
2797 # first touch the runtime file to show we are still running:
2798 # the fsync below can take a very very long time.
2799
2800 IO::AIO::aio_utime $runtime, undef, undef;
2801
2802 my $guard = cf::lock_acquire "write_runtime";
2803
2804 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2805 or return;
2806
2807 my $value = $cf::RUNTIME + 90 + 10;
2808 # 10 is the runtime save interval, for a monotonic clock
2809 # 60 allows for the watchdog to kill the server.
2810
2811 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2812 and return;
2813
2814 # always fsync - this file is important
2815 aio_fsync $fh
2816 and return;
2817
2818 # touch it again to show we are up-to-date
2819 aio_utime $fh, undef, undef;
2820
2821 close $fh
2822 or return;
2823
2824 aio_rename "$runtime~", $runtime
2825 and return;
2826
2827 warn "runtime file written.\n";
2828
2829 1
2830}
2831
2314sub emergency_save() { 2832sub emergency_save() {
2315 my $freeze_guard = cf::freeze_mainloop; 2833 my $freeze_guard = cf::freeze_mainloop;
2316 2834
2317 warn "enter emergency perl save\n"; 2835 warn "enter emergency perl save\n";
2318 2836
2349 2867
2350 warn Carp::longmess "post_cleanup backtrace" 2868 warn Carp::longmess "post_cleanup backtrace"
2351 if $make_core; 2869 if $make_core;
2352} 2870}
2353 2871
2354sub reload() { 2872sub do_reload_perl() {
2355 # can/must only be called in main 2873 # can/must only be called in main
2356 if ($Coro::current != $Coro::main) { 2874 if ($Coro::current != $Coro::main) {
2357 warn "can only reload from main coroutine"; 2875 warn "can only reload from main coroutine";
2358 return; 2876 return;
2359 } 2877 }
2384 Coro::cede; 2902 Coro::cede;
2385 last unless IO::AIO::nreqs || BDB::nreqs; 2903 last unless IO::AIO::nreqs || BDB::nreqs;
2386 warn "iterate..."; 2904 warn "iterate...";
2387 } 2905 }
2388 2906
2907 ++$RELOAD;
2908
2389 warn "cancelling all extension coros"; 2909 warn "cancelling all extension coros";
2390 $_->cancel for values %EXT_CORO; 2910 $_->cancel for values %EXT_CORO;
2391 %EXT_CORO = (); 2911 %EXT_CORO = ();
2392 2912
2393 warn "removing commands"; 2913 warn "removing commands";
2394 %COMMAND = (); 2914 %COMMAND = ();
2395 2915
2396 warn "removing ext commands"; 2916 warn "removing ext/exti commands";
2397 %EXTCMD = (); 2917 %EXTCMD = ();
2918 %EXTICMD = ();
2398 2919
2399 warn "unloading/nuking all extensions"; 2920 warn "unloading/nuking all extensions";
2400 for my $pkg (@EXTS) { 2921 for my $pkg (@EXTS) {
2401 warn "... unloading $pkg"; 2922 warn "... unloading $pkg";
2402 2923
2432 Symbol::delete_package "safe::$_" 2953 Symbol::delete_package "safe::$_"
2433 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2954 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2434 2955
2435 warn "unloading cf.pm \"a bit\""; 2956 warn "unloading cf.pm \"a bit\"";
2436 delete $INC{"cf.pm"}; 2957 delete $INC{"cf.pm"};
2958 delete $INC{"cf/pod.pm"};
2437 2959
2438 # don't, removes xs symbols, too, 2960 # don't, removes xs symbols, too,
2439 # and global variables created in xs 2961 # and global variables created in xs
2440 #Symbol::delete_package __PACKAGE__; 2962 #Symbol::delete_package __PACKAGE__;
2441 2963
2450 2972
2451 warn "loading extensions"; 2973 warn "loading extensions";
2452 cf::load_extensions; 2974 cf::load_extensions;
2453 2975
2454 warn "reattaching attachments to objects/players"; 2976 warn "reattaching attachments to objects/players";
2455 _global_reattach; 2977 _global_reattach; # objects, sockets
2456 warn "reattaching attachments to maps"; 2978 warn "reattaching attachments to maps";
2457 reattach $_ for values %MAP; 2979 reattach $_ for values %MAP;
2458 2980 warn "reattaching attachments to players";
2459 warn "loading reloadable resources"; 2981 reattach $_ for values %PLAYER;
2460 init_resources;
2461 2982
2462 warn "leaving sync_job"; 2983 warn "leaving sync_job";
2463 2984
2464 1 2985 1
2465 } or do { 2986 } or do {
2471 warn "reloaded"; 2992 warn "reloaded";
2472}; 2993};
2473 2994
2474our $RELOAD_WATCHER; # used only during reload 2995our $RELOAD_WATCHER; # used only during reload
2475 2996
2997sub reload_perl() {
2998 # doing reload synchronously and two reloads happen back-to-back,
2999 # coro crashes during coro_state_free->destroy here.
3000
3001 $RELOAD_WATCHER ||= Event->timer (
3002 reentrant => 0,
3003 after => 0,
3004 data => WF_AUTOCANCEL,
3005 cb => sub {
3006 do_reload_perl;
3007 undef $RELOAD_WATCHER;
3008 },
3009 );
3010}
3011
2476register_command "reload" => sub { 3012register_command "reload" => sub {
2477 my ($who, $arg) = @_; 3013 my ($who, $arg) = @_;
2478 3014
2479 if ($who->flag (FLAG_WIZ)) { 3015 if ($who->flag (FLAG_WIZ)) {
2480 $who->message ("reloading server."); 3016 $who->message ("reloading server.");
2481 3017 async { reload_perl };
2482 # doing reload synchronously and two reloads happen back-to-back,
2483 # coro crashes during coro_state_free->destroy here.
2484
2485 $RELOAD_WATCHER ||= Event->timer (
2486 reentrant => 0,
2487 after => 0,
2488 data => WF_AUTOCANCEL,
2489 cb => sub {
2490 reload;
2491 undef $RELOAD_WATCHER;
2492 },
2493 );
2494 } 3018 }
2495}; 3019};
2496 3020
2497unshift @INC, $LIBDIR; 3021unshift @INC, $LIBDIR;
2498 3022
2499my $bug_warning = 0; 3023my $bug_warning = 0;
2500 3024
3025our @WAIT_FOR_TICK;
3026our @WAIT_FOR_TICK_BEGIN;
3027
3028sub wait_for_tick {
3029 return unless $TICK_WATCHER->is_active;
3030 return if $Coro::current == $Coro::main;
3031
3032 my $signal = new Coro::Signal;
3033 push @WAIT_FOR_TICK, $signal;
3034 $signal->wait;
3035}
3036
3037sub wait_for_tick_begin {
3038 return unless $TICK_WATCHER->is_active;
3039 return if $Coro::current == $Coro::main;
3040
3041 my $signal = new Coro::Signal;
3042 push @WAIT_FOR_TICK_BEGIN, $signal;
3043 $signal->wait;
3044}
3045
3046 my $min = 1e6;#d#
3047 my $avg = 10;
2501$TICK_WATCHER = Event->timer ( 3048$TICK_WATCHER = Event->timer (
2502 reentrant => 0, 3049 reentrant => 0,
2503 parked => 1, 3050 parked => 1,
2504 prio => 0, 3051 prio => 0,
2505 at => $NEXT_TICK || $TICK, 3052 at => $NEXT_TICK || $TICK,
2509 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3056 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2510 unless ++$bug_warning > 10; 3057 unless ++$bug_warning > 10;
2511 return; 3058 return;
2512 } 3059 }
2513 3060
2514 $NOW = Event::time; 3061 $NOW = $tick_start = Event::time;
2515 3062
2516 cf::server_tick; # one server iteration 3063 cf::server_tick; # one server iteration
3064
3065 0 && sync_job {#d#
3066 for(1..10) {
3067 my $t = Event::time;
3068 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3069 or die;
3070
3071 $map->width (50);
3072 $map->height (50);
3073 $map->alloc;
3074 $map->_load_objects ("/tmp/x.map", 1);
3075 my $t = Event::time - $t;
3076
3077 #next unless $t < 0.0013;#d#
3078 if ($t < $min) {
3079 $min = $t;
3080 }
3081 $avg = $avg * 0.99 + $t * 0.01;
3082 }
3083 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3084 exit 0;
3085 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3086 };
3087
2517 $RUNTIME += $TICK; 3088 $RUNTIME += $TICK;
2518 $NEXT_TICK += $TICK; 3089 $NEXT_TICK += $TICK;
2519 3090
2520 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3091 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2521 $NEXT_RUNTIME_WRITE = $NOW + 10; 3092 $NEXT_RUNTIME_WRITE = $NOW + 10;
2523 write_runtime 3094 write_runtime
2524 or warn "ERROR: unable to write runtime file: $!"; 3095 or warn "ERROR: unable to write runtime file: $!";
2525 }; 3096 };
2526 } 3097 }
2527 3098
2528 $WAIT_FOR_TICK->broadcast;
2529 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2530
2531# my $AFTER = Event::time; 3099# my $AFTER = Event::time;
2532# warn $AFTER - $NOW;#d# 3100# warn $AFTER - $NOW;#d#
2533 3101
3102 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3103 $sig->send;
3104 }
3105 while (my $sig = shift @WAIT_FOR_TICK) {
3106 $sig->send;
3107 }
3108
3109 $NOW = Event::time;
3110
2534 # if we are delayed by four ticks or more, skip them all 3111 # if we are delayed by four ticks or more, skip them all
2535 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3112 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2536 3113
2537 $TICK_WATCHER->at ($NEXT_TICK); 3114 $TICK_WATCHER->at ($NEXT_TICK);
2538 $TICK_WATCHER->start; 3115 $TICK_WATCHER->start;
3116
3117 $LOAD = ($NOW - $tick_start) / $TICK;
3118 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3119
3120 _post_tick;
3121
3122
2539 }, 3123 },
2540); 3124);
2541 3125
2542{ 3126{
2543 BDB::max_poll_time $TICK * 0.1; 3127 BDB::max_poll_time $TICK * 0.1;
2571 3155
2572 cf::sync_job { 3156 cf::sync_job {
2573 eval { 3157 eval {
2574 BDB::db_env_open 3158 BDB::db_env_open
2575 $DB_ENV, 3159 $DB_ENV,
2576 $BDB_ENV_DIR, 3160 $BDBDIR,
2577 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3161 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2578 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3162 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2579 0666; 3163 0666;
2580 3164
2581 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!; 3165 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2582 3166
2583 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1); 3167 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2584 $DB_ENV->set_lk_detect; 3168 $DB_ENV->set_lk_detect;
2585 }; 3169 };
2586 3170
2602 prio => 6, 3186 prio => 6,
2603 cb => \&IO::AIO::poll_cb, 3187 cb => \&IO::AIO::poll_cb,
2604 ); 3188 );
2605} 3189}
2606 3190
3191my $_log_backtrace;
3192
3193sub _log_backtrace {
3194 my ($msg, @addr) = @_;
3195
3196 $msg =~ s/\n//;
3197
3198 # limit the # of concurrent backtraces
3199 if ($_log_backtrace < 2) {
3200 ++$_log_backtrace;
3201 async {
3202 my @bt = fork_call {
3203 @addr = map { sprintf "%x", $_ } @addr;
3204 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3205 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3206 or die "addr2line: $!";
3207
3208 my @funcs;
3209 my @res = <$fh>;
3210 chomp for @res;
3211 while (@res) {
3212 my ($func, $line) = splice @res, 0, 2, ();
3213 push @funcs, "[$func] $line";
3214 }
3215
3216 @funcs
3217 };
3218
3219 LOG llevInfo, "[ABT] $msg\n";
3220 LOG llevInfo, "[ABT] $_\n" for @bt;
3221 --$_log_backtrace;
3222 };
3223 } else {
3224 LOG llevInfo, "[ABT] $msg\n";
3225 LOG llevInfo, "[ABT] [suppressed]\n";
3226 }
3227}
3228
3229# load additional modules
3230use cf::pod;
3231
2607END { cf::emergency_save } 3232END { cf::emergency_save }
2608 3233
26091 32341
2610 3235

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines