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.198 by root, Sun Jan 28 01:58:37 2007 UTC vs.
Revision 1.284 by root, Sun Jun 24 04:15:42 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 BDB ();
20use Data::Dumper; 26use Data::Dumper;
21use Digest::MD5; 27use Digest::MD5;
22use Fcntl; 28use Fcntl;
29use YAML::Syck ();
23use IO::AIO 2.32 (); 30use IO::AIO 2.32 ();
24use YAML::Syck ();
25use Time::HiRes; 31use Time::HiRes;
32use Compress::LZF;
26 33
34# configure various modules to our taste
35#
36$Storable::canonical = 1; # reduce rsync transfers
37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
38Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
39
27use Event; $Event::Eval = 1; # no idea why this is required, but it is 40$Event::Eval = 1; # no idea why this is required, but it is
28
29sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
30 41
31# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 42# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
32$YAML::Syck::ImplicitUnicode = 1; 43$YAML::Syck::ImplicitUnicode = 1;
33 44
34$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 45$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
46
47sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
35 48
36our %COMMAND = (); 49our %COMMAND = ();
37our %COMMAND_TIME = (); 50our %COMMAND_TIME = ();
38 51
39our @EXTS = (); # list of extension package names 52our @EXTS = (); # list of extension package names
40our %EXTCMD = (); 53our %EXTCMD = ();
41our %EXT_CORO = (); # coroutines bound to extensions 54our %EXT_CORO = (); # coroutines bound to extensions
42our %EXT_MAP = (); # pluggable maps 55our %EXT_MAP = (); # pluggable maps
43 56
57our $RELOAD; # number of reloads so far
44our @EVENT; 58our @EVENT;
45our $LIBDIR = datadir . "/ext";
46 59
47our $TICK = MAX_TIME * 1e-6; 60our $CONFDIR = confdir;
61our $DATADIR = datadir;
62our $LIBDIR = "$DATADIR/ext";
63our $PODDIR = "$DATADIR/pod";
64our $MAPDIR = "$DATADIR/" . mapdir;
65our $LOCALDIR = localdir;
66our $TMPDIR = "$LOCALDIR/" . tmpdir;
67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
68our $PLAYERDIR = "$LOCALDIR/" . playerdir;
69our $RANDOMDIR = "$LOCALDIR/random";
70our $BDBDIR = "$LOCALDIR/db";
71
72our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
48our $TICK_WATCHER; 73our $TICK_WATCHER;
49our $AIO_POLL_WATCHER; 74our $AIO_POLL_WATCHER;
50our $WRITE_RUNTIME_WATCHER; 75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
51our $NEXT_TICK; 76our $NEXT_TICK;
52our $NOW; 77our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off
79
80our $BDB_POLL_WATCHER;
81our $DB_ENV;
53 82
54our %CFG; 83our %CFG;
55 84
56our $UPTIME; $UPTIME ||= time; 85our $UPTIME; $UPTIME ||= time;
57our $RUNTIME; 86our $RUNTIME;
58 87
59our %PLAYER; # all users 88our %PLAYER; # all users
60our %MAP; # all maps 89our %MAP; # all maps
61our $LINK_MAP; # the special {link} map, which is always available 90our $LINK_MAP; # the special {link} map, which is always available
62our $RANDOM_MAPS = cf::localdir . "/random";
63
64our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
65our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
66 91
67# used to convert map paths into valid unix filenames by replacing / by ∕ 92# used to convert map paths into valid unix filenames by replacing / by ∕
68our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
69 94
95our $LOAD; # a number between 0 (idle) and 1 (too many objects)
96our $LOADAVG; # same thing, but with alpha-smoothing
97our $tick_start; # for load detecting purposes
98
70binmode STDOUT; 99binmode STDOUT;
71binmode STDERR; 100binmode STDERR;
72 101
73# read virtual server time, if available 102# read virtual server time, if available
74unless ($RUNTIME || !-e cf::localdir . "/runtime") { 103unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
75 open my $fh, "<", cf::localdir . "/runtime" 104 open my $fh, "<", "$LOCALDIR/runtime"
76 or die "unable to read runtime file: $!"; 105 or die "unable to read runtime file: $!";
77 $RUNTIME = <$fh> + 0.; 106 $RUNTIME = <$fh> + 0.;
78} 107}
79 108
80mkdir cf::localdir; 109mkdir $_
81mkdir cf::localdir . "/" . cf::playerdir; 110 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
82mkdir cf::localdir . "/" . cf::tmpdir;
83mkdir cf::localdir . "/" . cf::uniquedir;
84mkdir $RANDOM_MAPS;
85 111
86our $EMERGENCY_POSITION; 112our $EMERGENCY_POSITION;
113
114sub cf::map::normalise;
87 115
88############################################################################# 116#############################################################################
89 117
90=head2 GLOBAL VARIABLES 118=head2 GLOBAL VARIABLES
91 119
98=item $cf::RUNTIME 126=item $cf::RUNTIME
99 127
100The time this server has run, starts at 0 and is increased by $cf::TICK on 128The time this server has run, starts at 0 and is increased by $cf::TICK on
101every server tick. 129every server tick.
102 130
103=item $cf::LIBDIR 131=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
132$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
133$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
104 134
105The perl library directory, where extensions and cf-specific modules can 135Various directories - "/etc", read-only install directory, perl-library
106be found. It will be added to C<@INC> automatically. 136directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
137unique-items directory, player file directory, random maps directory and
138database environment.
107 139
108=item $cf::NOW 140=item $cf::NOW
109 141
110The time of the last (current) server tick. 142The time of the last (current) server tick.
111 143
112=item $cf::TICK 144=item $cf::TICK
113 145
114The interval between server ticks, in seconds. 146The interval between server ticks, in seconds.
147
148=item $cf::LOADAVG
149
150The current CPU load on the server (alpha-smoothed), as a value between 0
151(none) and 1 (overloaded), indicating how much time is spent on processing
152objects per tick. Healthy values are < 0.5.
153
154=item $cf::LOAD
155
156The raw value load value from the last tick.
115 157
116=item %cf::CFG 158=item %cf::CFG
117 159
118Configuration for the server, loaded from C</etc/crossfire/config>, or 160Configuration for the server, loaded from C</etc/crossfire/config>, or
119from wherever your confdir points to. 161from wherever your confdir points to.
120 162
121=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 163=item cf::wait_for_tick, cf::wait_for_tick_begin
122 164
123These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK) 165These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
124or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick 166returns directly I<after> the tick processing (and consequently, can only wake one process
125processing has been done. Call C<< ->wait >> on them to maximise the 167per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
126window of cpu time available, or simply to synchronise to the server tick.
127 168
128=back 169=back
129 170
130=cut 171=cut
131 172
132BEGIN { 173BEGIN {
133 *CORE::GLOBAL::warn = sub { 174 *CORE::GLOBAL::warn = sub {
134 my $msg = join "", @_; 175 my $msg = join "", @_;
135 utf8::encode $msg;
136 176
137 $msg .= "\n" 177 $msg .= "\n"
138 unless $msg =~ /\n$/; 178 unless $msg =~ /\n$/;
139 179
180 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
181
182 utf8::encode $msg;
140 LOG llevError, $msg; 183 LOG llevError, $msg;
141 }; 184 };
142} 185}
143 186
144@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
145@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
146@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
147@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
148@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 191@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
192@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
149@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 193@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
150 194
151# we bless all objects into (empty) derived classes to force a method lookup 195# we bless all objects into (empty) derived classes to force a method lookup
152# within the Safe compartment. 196# within the Safe compartment.
153for my $pkg (qw( 197for my $pkg (qw(
154 cf::global cf::attachable 198 cf::global cf::attachable
162} 206}
163 207
164$Event::DIED = sub { 208$Event::DIED = sub {
165 warn "error in event callback: @_"; 209 warn "error in event callback: @_";
166}; 210};
211
212#############################################################################
167 213
168=head2 UTILITY FUNCTIONS 214=head2 UTILITY FUNCTIONS
169 215
170=over 4 216=over 4
171 217
190 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 236 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
191 $d 237 $d
192 } || "[unable to dump $_[0]: '$@']"; 238 } || "[unable to dump $_[0]: '$@']";
193} 239}
194 240
195use JSON::Syck (); # TODO# replace by JSON::PC once working 241use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
196 242
197=item $ref = cf::from_json $json 243=item $ref = cf::from_json $json
198 244
199Converts a JSON string into the corresponding perl data structure. 245Converts a JSON string into the corresponding perl data structure.
200 246
201=cut
202
203sub from_json($) {
204 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
205 JSON::Syck::Load $_[0]
206}
207
208=item $json = cf::to_json $ref 247=item $json = cf::to_json $ref
209 248
210Converts a perl data structure into its JSON representation. 249Converts a perl data structure into its JSON representation.
211
212=cut
213
214sub to_json($) {
215 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
216 JSON::Syck::Dump $_[0]
217}
218 250
219=item cf::lock_wait $string 251=item cf::lock_wait $string
220 252
221Wait until the given lock is available. See cf::lock_acquire. 253Wait until the given lock is available. See cf::lock_acquire.
222 254
228returned. 260returned.
229 261
230Lock names should begin with a unique identifier (for example, cf::map::find 262Lock names should begin with a unique identifier (for example, cf::map::find
231uses map_find and cf::map::load uses map_load). 263uses map_find and cf::map::load uses map_load).
232 264
265=item $locked = cf::lock_active $string
266
267Return true if the lock is currently active, i.e. somebody has locked it.
268
233=cut 269=cut
234 270
235our %LOCK; 271our %LOCK;
236 272
237sub lock_wait($) { 273sub lock_wait($) {
256 # wake up all waiters, to be on the safe side 292 # wake up all waiters, to be on the safe side
257 $_->ready for @{ delete $LOCK{$key} }; 293 $_->ready for @{ delete $LOCK{$key} };
258 } 294 }
259} 295}
260 296
297sub lock_active($) {
298 my ($key) = @_;
299
300 ! ! $LOCK{$key}
301}
302
261sub freeze_mainloop { 303sub freeze_mainloop {
262 return unless $TICK_WATCHER->is_active; 304 return unless $TICK_WATCHER->is_active;
263 305
264 my $guard = Coro::guard { 306 my $guard = Coro::guard {
265 $TICK_WATCHER->start; 307 $TICK_WATCHER->start;
266 $WRITE_RUNTIME_WATCHER->start;
267 }; 308 };
268 $WRITE_RUNTIME_WATCHER->stop;
269 $TICK_WATCHER->stop; 309 $TICK_WATCHER->stop;
270 $guard 310 $guard
271} 311}
272 312
273=item cf::async { BLOCK } 313=item cf::async { BLOCK }
280 320
281BEGIN { *async = \&Coro::async_pool } 321BEGIN { *async = \&Coro::async_pool }
282 322
283=item cf::sync_job { BLOCK } 323=item cf::sync_job { BLOCK }
284 324
285The design of crossfire+ requires that the main coro ($Coro::main) is 325The design of Crossfire TRT requires that the main coroutine ($Coro::main)
286always able to handle events or runnable, as crossfire+ is only partly 326is always able to handle events or runnable, as Crossfire TRT is only
287reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 327partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
328acceptable.
288 329
289If it must be done, put the blocking parts into C<sync_job>. This will run 330If it must be done, put the blocking parts into C<sync_job>. This will run
290the given BLOCK in another coroutine while waiting for the result. The 331the given BLOCK in another coroutine while waiting for the result. The
291server will be frozen during this time, so the block should either finish 332server will be frozen during this time, so the block should either finish
292fast or be very important. 333fast or be very important.
295 336
296sub sync_job(&) { 337sub sync_job(&) {
297 my ($job) = @_; 338 my ($job) = @_;
298 339
299 if ($Coro::current == $Coro::main) { 340 if ($Coro::current == $Coro::main) {
341 my $time = Event::time;
342
300 # this is the main coro, too bad, we have to block 343 # this is the main coro, too bad, we have to block
301 # till the operation succeeds, freezing the server :/ 344 # till the operation succeeds, freezing the server :/
302 345
303 # TODO: use suspend/resume instead 346 # TODO: use suspend/resume instead
304 # (but this is cancel-safe) 347 # (but this is cancel-safe)
315 358
316 while ($busy) { 359 while ($busy) {
317 Coro::cede or Event::one_event; 360 Coro::cede or Event::one_event;
318 } 361 }
319 362
363 $time = Event::time - $time;
364
365 LOG llevError | logBacktrace, Carp::longmess "long sync job"
366 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
367
368 $tick_start += $time; # do not account sync jobs to server load
369
320 wantarray ? @res : $res[0] 370 wantarray ? @res : $res[0]
321 } else { 371 } else {
322 # we are in another coroutine, how wonderful, everything just works 372 # we are in another coroutine, how wonderful, everything just works
323 373
324 $job->() 374 $job->()
343 $EXT_CORO{$coro+0} = $coro; 393 $EXT_CORO{$coro+0} = $coro;
344 394
345 $coro 395 $coro
346} 396}
347 397
348sub write_runtime { 398=item fork_call { }, $args
349 my $runtime = cf::localdir . "/runtime";
350 399
351 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 400Executes the given code block with the given arguments in a seperate
352 or return; 401process, returning the results. Everything must be serialisable with
402Coro::Storable. May, of course, block. Note that the executed sub may
403never block itself or use any form of Event handling.
353 404
354 my $value = $cf::RUNTIME + 90 + 10; 405=cut
355 # 10 is the runtime save interval, for a monotonic clock
356 # 60 allows for the watchdog to kill the server.
357 406
358 (aio_write $fh, 0, (length $value), $value, 0) <= 0 407sub fork_call(&@) {
359 and return; 408 my ($cb, @args) = @_;
360 409
361 aio_fsync $fh 410# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
362 and return; 411# or die "socketpair: $!";
412 pipe my $fh1, my $fh2
413 or die "pipe: $!";
363 414
415 if (my $pid = fork) {
364 close $fh 416 close $fh2;
365 or return;
366 417
367 aio_rename "$runtime~", $runtime 418 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
368 and return; 419 $res = Coro::Storable::thaw $res;
369 420
421 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
422
423 die $$res unless "ARRAY" eq ref $res;
424
425 return wantarray ? @$res : $res->[-1];
426 } else {
427 reset_signals;
428 local $SIG{__WARN__};
429 local $SIG{__DIE__};
430 eval {
431 close $fh1;
432
433 my @res = eval { $cb->(@args) };
434 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
435 };
436
437 warn $@ if $@;
438 _exit 0;
370 1 439 }
440}
441
442=item $value = cf::db_get $family => $key
443
444Returns a single value from the environment database.
445
446=item cf::db_put $family => $key => $value
447
448Stores the given C<$value> in the family. It can currently store binary
449data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
450
451=cut
452
453our $DB;
454
455sub db_init {
456 unless ($DB) {
457 $DB = BDB::db_create $DB_ENV;
458
459 cf::sync_job {
460 eval {
461 $DB->set_flags (BDB::CHKSUM);
462
463 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
464 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
465 cf::cleanup "db_open(db): $!" if $!;
466 };
467 cf::cleanup "db_open(db): $@" if $@;
468 };
469 }
470}
471
472sub db_get($$) {
473 my $key = "$_[0]/$_[1]";
474
475 cf::sync_job {
476 BDB::db_get $DB, undef, $key, my $data;
477
478 $! ? ()
479 : $data
480 }
481}
482
483sub db_put($$$) {
484 BDB::dbreq_pri 4;
485 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
486}
487
488=item cf::cache $id => [$paths...], $processversion => $process
489
490Generic caching function that returns the value of the resource $id,
491caching and regenerating as required.
492
493This function can block.
494
495=cut
496
497sub cache {
498 my ($id, $src, $processversion, $process) = @_;
499
500 my $meta =
501 join "\x00",
502 $processversion,
503 map {
504 aio_stat $_
505 and Carp::croak "$_: $!";
506
507 ($_, (stat _)[7,9])
508 } @$src;
509
510 my $dbmeta = db_get cache => "$id/meta";
511 if ($dbmeta ne $meta) {
512 # changed, we may need to process
513
514 my @data;
515 my $md5;
516
517 for (0 .. $#$src) {
518 0 <= aio_load $src->[$_], $data[$_]
519 or Carp::croak "$src->[$_]: $!";
520 }
521
522 # if processing is expensive, check
523 # checksum first
524 if (1) {
525 $md5 =
526 join "\x00",
527 $processversion,
528 map {
529 Coro::cede;
530 ($src->[$_], Digest::MD5::md5_hex $data[$_])
531 } 0.. $#$src;
532
533
534 my $dbmd5 = db_get cache => "$id/md5";
535 if ($dbmd5 eq $md5) {
536 db_put cache => "$id/meta", $meta;
537
538 return db_get cache => "$id/data";
539 }
540 }
541
542 my $t1 = Time::HiRes::time;
543 my $data = $process->(\@data);
544 my $t2 = Time::HiRes::time;
545
546 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
547
548 db_put cache => "$id/data", $data;
549 db_put cache => "$id/md5" , $md5;
550 db_put cache => "$id/meta", $meta;
551
552 return $data;
553 }
554
555 db_get cache => "$id/data"
556}
557
558=item cf::datalog type => key => value, ...
559
560Log a datalog packet of the given type with the given key-value pairs.
561
562=cut
563
564sub datalog($@) {
565 my ($type, %kv) = @_;
566 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
371} 567}
372 568
373=back 569=back
374 570
375=cut 571=cut
382attach callbacks/event handlers (a collection of which is called an "attachment") 578attach callbacks/event handlers (a collection of which is called an "attachment")
383to it. All such attachable objects support the following methods. 579to it. All such attachable objects support the following methods.
384 580
385In the following description, CLASS can be any of C<global>, C<object> 581In the following description, CLASS can be any of C<global>, C<object>
386C<player>, C<client> or C<map> (i.e. the attachable objects in 582C<player>, C<client> or C<map> (i.e. the attachable objects in
387crossfire+). 583Crossfire TRT).
388 584
389=over 4 585=over 4
390 586
391=item $attachable->attach ($attachment, key => $value...) 587=item $attachable->attach ($attachment, key => $value...)
392 588
555 $registry = $CB_TYPE[$object_type] ||= []; 751 $registry = $CB_TYPE[$object_type] ||= [];
556 752
557 } elsif ($type eq "subtype") { 753 } elsif ($type eq "subtype") {
558 defined $object_type or Carp::croak "subtype specified without type"; 754 defined $object_type or Carp::croak "subtype specified without type";
559 my $object_subtype = shift @arg; 755 my $object_subtype = shift @arg;
560 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 756 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
561 757
562 } elsif ($type eq "package") { 758 } elsif ($type eq "package") {
563 my $pkg = shift @arg; 759 my $pkg = shift @arg;
564 760
565 while (my ($name, $id) = each %cb_id) { 761 while (my ($name, $id) = each %cb_id) {
594 _attach $registry, $klass, @attach; 790 _attach $registry, $klass, @attach;
595 } 791 }
596 792
597 $obj->{$name} = \%arg; 793 $obj->{$name} = \%arg;
598 } else { 794 } else {
599 warn "object uses attachment '$name' that is not available, postponing.\n"; 795 warn "object uses attachment '$name' which is not available, postponing.\n";
600 } 796 }
601 797
602 $obj->{_attachment}{$name} = undef; 798 $obj->{_attachment}{$name} = undef;
603} 799}
604 800
606 if (ref $_[0]) { 802 if (ref $_[0]) {
607 _object_attach @_; 803 _object_attach @_;
608 } else { 804 } else {
609 _attach shift->_attach_registry, @_; 805 _attach shift->_attach_registry, @_;
610 } 806 }
807 _recalc_want;
611}; 808};
612 809
613# all those should be optimised 810# all those should be optimised
614sub cf::attachable::detach { 811sub cf::attachable::detach {
615 my ($obj, $name) = @_; 812 my ($obj, $name) = @_;
618 delete $obj->{_attachment}{$name}; 815 delete $obj->{_attachment}{$name};
619 reattach ($obj); 816 reattach ($obj);
620 } else { 817 } else {
621 Carp::croak "cannot, currently, detach class attachments"; 818 Carp::croak "cannot, currently, detach class attachments";
622 } 819 }
820 _recalc_want;
623}; 821};
624 822
625sub cf::attachable::attached { 823sub cf::attachable::attached {
626 my ($obj, $name) = @_; 824 my ($obj, $name) = @_;
627 825
750 $filename, length $$rdata, scalar @$objs; 948 $filename, length $$rdata, scalar @$objs;
751 949
752 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 950 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
753 chmod SAVE_MODE, $fh; 951 chmod SAVE_MODE, $fh;
754 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 952 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
755 aio_fsync $fh; 953 aio_fsync $fh if $cf::USE_FSYNC;
756 close $fh; 954 close $fh;
757 955
758 if (@$objs) { 956 if (@$objs) {
759 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 957 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
760 chmod SAVE_MODE, $fh; 958 chmod SAVE_MODE, $fh;
761 my $data = Storable::nfreeze { version => 1, objs => $objs }; 959 my $data = Storable::nfreeze { version => 1, objs => $objs };
762 aio_write $fh, 0, (length $data), $data, 0; 960 aio_write $fh, 0, (length $data), $data, 0;
763 aio_fsync $fh; 961 aio_fsync $fh if $cf::USE_FSYNC;
764 close $fh; 962 close $fh;
765 aio_rename "$filename.pst~", "$filename.pst"; 963 aio_rename "$filename.pst~", "$filename.pst";
766 } 964 }
767 } else { 965 } else {
768 aio_unlink "$filename.pst"; 966 aio_unlink "$filename.pst";
800 or return; 998 or return;
801 $av = eval { (Storable::thaw $av)->{objs} }; 999 $av = eval { (Storable::thaw $av)->{objs} };
802 } 1000 }
803 1001
804 warn sprintf "loading %s (%d)\n", 1002 warn sprintf "loading %s (%d)\n",
805 $filename, length $data, scalar @{$av || []};#d# 1003 $filename, length $data, scalar @{$av || []};
806 return ($data, $av); 1004 return ($data, $av);
807} 1005}
1006
1007=head2 COMMAND CALLBACKS
1008
1009=over 4
1010
1011=cut
808 1012
809############################################################################# 1013#############################################################################
810# command handling &c 1014# command handling &c
811 1015
812=item cf::register_command $name => \&callback($ob,$args); 1016=item cf::register_command $name => \&callback($ob,$args);
825 push @{ $COMMAND{$name} }, [$caller, $cb]; 1029 push @{ $COMMAND{$name} }, [$caller, $cb];
826} 1030}
827 1031
828=item cf::register_extcmd $name => \&callback($pl,$packet); 1032=item cf::register_extcmd $name => \&callback($pl,$packet);
829 1033
830Register a callbackf ro execution when the client sends an extcmd packet. 1034Register a callback fro execution when the client sends an extcmd packet.
831 1035
832If the callback returns something, it is sent back as if reply was being 1036If the callback returns something, it is sent back as if reply was being
833called. 1037called.
834 1038
835=cut 1039=cut
870 1074
871 cf::override; 1075 cf::override;
872 }, 1076 },
873); 1077);
874 1078
875sub load_extension {
876 my ($path) = @_;
877
878 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
879 my $base = $1;
880 my $pkg = $1;
881 $pkg =~ s/[^[:word:]]/_/g;
882 $pkg = "ext::$pkg";
883
884 warn "... loading '$path' into '$pkg'\n";
885
886 open my $fh, "<:utf8", $path
887 or die "$path: $!";
888
889 my $source =
890 "package $pkg; use strict; use utf8;\n"
891 . "#line 1 \"$path\"\n{\n"
892 . (do { local $/; <$fh> })
893 . "\n};\n1";
894
895 unless (eval $source) {
896 my $msg = $@ ? "$path: $@\n"
897 : "extension disabled.\n";
898 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
899 warn $@;
900 warn "mandatory extension failed to load, exiting.\n";
901 exit 1;
902 }
903 die $@;
904 }
905
906 push @EXTS, $pkg;
907}
908
909sub load_extensions { 1079sub load_extensions {
1080 cf::sync_job {
1081 my %todo;
1082
910 for my $ext (<$LIBDIR/*.ext>) { 1083 for my $path (<$LIBDIR/*.ext>) {
911 next unless -r $ext; 1084 next unless -r $path;
912 eval { 1085
913 load_extension $ext; 1086 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1087 my $base = $1;
1088 my $pkg = $1;
1089 $pkg =~ s/[^[:word:]]/_/g;
1090 $pkg = "ext::$pkg";
1091
1092 open my $fh, "<:utf8", $path
1093 or die "$path: $!";
1094
1095 my $source = do { local $/; <$fh> };
1096
1097 my %ext = (
1098 path => $path,
1099 base => $base,
1100 pkg => $pkg,
1101 );
1102
1103 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1104 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1105
1106 $ext{source} =
1107 "package $pkg; use strict; use utf8;\n"
1108 . "#line 1 \"$path\"\n{\n"
1109 . $source
1110 . "\n};\n1";
1111
1112 $todo{$base} = \%ext;
1113 }
1114
1115 my %done;
1116 while (%todo) {
1117 my $progress;
1118
1119 while (my ($k, $v) = each %todo) {
1120 for (split /,\s*/, $v->{meta}{depends}) {
1121 goto skip
1122 unless exists $done{$_};
1123 }
1124
1125 warn "... loading '$k' into '$v->{pkg}'\n";
1126
1127 unless (eval $v->{source}) {
1128 my $msg = $@ ? "$v->{path}: $@\n"
1129 : "$v->{base}: extension inactive.\n";
1130
1131 if (exists $v->{meta}{mandatory}) {
1132 warn $msg;
1133 warn "mandatory extension failed to load, exiting.\n";
1134 exit 1;
1135 }
1136
1137 warn $msg;
1138 }
1139
1140 $done{$k} = delete $todo{$k};
1141 push @EXTS, $v->{pkg};
1142 $progress = 1;
914 1 1143 }
915 } or warn "$ext not loaded: $@"; 1144
1145 skip:
1146 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1147 unless $progress;
1148 }
916 } 1149 };
917} 1150}
918 1151
919############################################################################# 1152#############################################################################
920 1153
1154=back
1155
921=head2 CORE EXTENSIONS 1156=head2 CORE EXTENSIONS
922 1157
923Functions and methods that extend core crossfire objects. 1158Functions and methods that extend core crossfire objects.
924 1159
925=cut 1160=cut
937Returns the given player object, loading it if necessary (might block). 1172Returns the given player object, loading it if necessary (might block).
938 1173
939=cut 1174=cut
940 1175
941sub playerdir($) { 1176sub playerdir($) {
942 cf::localdir 1177 "$PLAYERDIR/"
943 . "/"
944 . cf::playerdir
945 . "/"
946 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1178 . (ref $_[0] ? $_[0]->ob->name : $_[0])
947} 1179}
948 1180
949sub path($) { 1181sub path($) {
950 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1182 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
951 1183
952 (playerdir $login) . "/$login.pl" 1184 (playerdir $login) . "/playerdata"
953} 1185}
954 1186
955sub find_active($) { 1187sub find_active($) {
956 $cf::PLAYER{$_[0]} 1188 $cf::PLAYER{$_[0]}
957 and $cf::PLAYER{$_[0]}->active 1189 and $cf::PLAYER{$_[0]}->active
970 my $login = $_[0]; 1202 my $login = $_[0];
971 1203
972 my $guard = cf::lock_acquire "user_find:$login"; 1204 my $guard = cf::lock_acquire "user_find:$login";
973 1205
974 $cf::PLAYER{$_[0]} || do { 1206 $cf::PLAYER{$_[0]} || do {
1207 # rename old playerfiles to new ones
1208 #TODO: remove when no longer required
1209 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1210 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1211 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1212 aio_unlink +(playerdir $login) . "/$login.pl";
1213
975 my $pl = load_pl path $login 1214 my $pl = load_pl path $login
976 or return; 1215 or return;
977 $cf::PLAYER{$login} = $pl 1216 $cf::PLAYER{$login} = $pl
978 } 1217 }
979 } 1218 }
1016 1255
1017=cut 1256=cut
1018 1257
1019sub quit_character { 1258sub quit_character {
1020 my ($pl) = @_; 1259 my ($pl) = @_;
1260
1261 my $name = $pl->ob->name;
1021 1262
1022 $pl->{deny_save} = 1; 1263 $pl->{deny_save} = 1;
1023 $pl->password ("*"); # this should lock out the player until we nuked the dir 1264 $pl->password ("*"); # this should lock out the player until we nuked the dir
1024 1265
1025 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1266 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1030 my $path = playerdir $pl; 1271 my $path = playerdir $pl;
1031 my $temp = "$path~$cf::RUNTIME~deleting~"; 1272 my $temp = "$path~$cf::RUNTIME~deleting~";
1032 aio_rename $path, $temp; 1273 aio_rename $path, $temp;
1033 delete $cf::PLAYER{$pl->ob->name}; 1274 delete $cf::PLAYER{$pl->ob->name};
1034 $pl->destroy; 1275 $pl->destroy;
1276
1277 my $prefix = qr<^~\Q$name\E/>;
1278
1279 # nuke player maps
1280 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1281
1035 IO::AIO::aio_rmtree $temp; 1282 IO::AIO::aio_rmtree $temp;
1283}
1284
1285=item $pl->kick
1286
1287Kicks a player out of the game. This destroys the connection.
1288
1289=cut
1290
1291sub kick {
1292 my ($pl, $kicker) = @_;
1293
1294 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1295 $pl->killer ("kicked");
1296 $pl->ns->destroy;
1036} 1297}
1037 1298
1038=item cf::player::list_logins 1299=item cf::player::list_logins
1039 1300
1040Returns am arrayref of all valid playernames in the system, can take a 1301Returns am arrayref of all valid playernames in the system, can take a
1041while and may block, so not sync_job-capable, ever. 1302while and may block, so not sync_job-capable, ever.
1042 1303
1043=cut 1304=cut
1044 1305
1045sub list_logins { 1306sub list_logins {
1046 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1307 my $dirs = aio_readdir $PLAYERDIR
1047 or return []; 1308 or return [];
1048 1309
1049 my @logins; 1310 my @logins;
1050 1311
1051 for my $login (@$dirs) { 1312 for my $login (@$dirs) {
1068=cut 1329=cut
1069 1330
1070sub maps($) { 1331sub maps($) {
1071 my ($pl) = @_; 1332 my ($pl) = @_;
1072 1333
1334 $pl = ref $pl ? $pl->ob->name : $pl;
1335
1073 my $files = aio_readdir playerdir $pl 1336 my $files = aio_readdir playerdir $pl
1074 or return; 1337 or return;
1075 1338
1076 my @paths; 1339 my @paths;
1077 1340
1078 for (@$files) { 1341 for (@$files) {
1079 utf8::decode $_; 1342 utf8::decode $_;
1080 next if /\.(?:pl|pst)$/; 1343 next if /\.(?:pl|pst)$/;
1081 next unless /^$PATH_SEP/o; 1344 next unless /^$PATH_SEP/o;
1082 1345
1083 s/\.map$//; 1346 push @paths, cf::map::normalise "~$pl/$_";
1084 push @paths, "~" . $pl->ob->name . "/" . $_;
1085 } 1347 }
1086 1348
1087 \@paths 1349 \@paths
1088} 1350}
1089 1351
1352=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1353
1354Expand crossfire pod fragments into protocol xml.
1355
1356=cut
1357
1358sub expand_cfpod {
1359 ((my $self), (local $_)) = @_;
1360
1361 # escape & and <
1362 s/&/&amp;/g;
1363 s/(?<![BIUGH])</&lt;/g;
1364
1365 # this is buggy, it needs to properly take care of nested <'s
1366
1367 1 while
1368 # replace B<>, I<>, U<> etc.
1369 s/B<([^\>]*)>/<b>$1<\/b>/
1370 || s/I<([^\>]*)>/<i>$1<\/i>/
1371 || s/U<([^\>]*)>/<u>$1<\/u>/
1372 # replace G<male|female> tags
1373 || s{G<([^>|]*)\|([^>]*)>}{
1374 $self->gender ? $2 : $1
1375 }ge
1376 # replace H<hint text>
1377 || s/H<([^\>]*)>/<fg name="lightblue">[$1]<\/fg>/g;
1378
1379 # create single paragraphs (very hackish)
1380 s/(?<=\S)\n(?=\w)/ /g;
1381
1382 $_
1383}
1384
1090=item $player->ext_reply ($msgid, $msgtype, %msg) 1385=item $player->ext_reply ($msgid, %msg)
1091 1386
1092Sends an ext reply to the player. 1387Sends an ext reply to the player.
1093 1388
1094=cut 1389=cut
1095 1390
1096sub ext_reply($$$%) { 1391sub ext_reply($$%) {
1097 my ($self, $id, %msg) = @_; 1392 my ($self, $id, %msg) = @_;
1098 1393
1099 $msg{msgid} = $id; 1394 $msg{msgid} = $id;
1100 1395
1101 $self->send ("ext " . cf::to_json \%msg); 1396 $self->send ("ext " . cf::to_json \%msg);
1102} 1397}
1103 1398
1104package cf; 1399=item $player->ext_event ($type, %msg)
1400
1401Sends an ext event to the client.
1402
1403=cut
1404
1405sub ext_event($$%) {
1406 my ($self, $type, %msg) = @_;
1407
1408 $self->ns->ext_event ($type, %msg);
1409}
1410
1411=head3 cf::region
1412
1413=over 4
1414
1415=cut
1416
1417package cf::region;
1418
1419=item cf::region::find_by_path $path
1420
1421Tries to decuce the likely region for a map knowing only its path.
1422
1423=cut
1424
1425sub find_by_path($) {
1426 my ($path) = @_;
1427
1428 my ($match, $specificity);
1429
1430 for my $region (list) {
1431 if ($region->match && $path =~ $region->match) {
1432 ($match, $specificity) = ($region, $region->specificity)
1433 if $region->specificity > $specificity;
1434 }
1435 }
1436
1437 $match
1438}
1105 1439
1106=back 1440=back
1107
1108 1441
1109=head3 cf::map 1442=head3 cf::map
1110 1443
1111=over 4 1444=over 4
1112 1445
1167 my ($self, $merge) = @_; 1500 my ($self, $merge) = @_;
1168 1501
1169 # we have to keep some variables in memory intact 1502 # we have to keep some variables in memory intact
1170 local $self->{path}; 1503 local $self->{path};
1171 local $self->{load_path}; 1504 local $self->{load_path};
1172 local $self->{deny_save};
1173 local $self->{deny_reset};
1174 1505
1175 $self->SUPER::thawer_merge ($merge); 1506 $self->SUPER::thawer_merge ($merge);
1176} 1507}
1177 1508
1178sub normalise { 1509sub normalise {
1179 my ($path, $base) = @_; 1510 my ($path, $base) = @_;
1180 1511
1181 $path = "$path"; # make sure its a string 1512 $path = "$path"; # make sure its a string
1513
1514 $path =~ s/\.map$//;
1182 1515
1183 # map plan: 1516 # map plan:
1184 # 1517 #
1185 # /! non-realised random map exit (special hack!) 1518 # /! non-realised random map exit (special hack!)
1186 # {... are special paths that are not being touched 1519 # {... are special paths that are not being touched
1248 1581
1249# the original (read-only) location 1582# the original (read-only) location
1250sub load_path { 1583sub load_path {
1251 my ($self) = @_; 1584 my ($self) = @_;
1252 1585
1253 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path} 1586 "$MAPDIR/$self->{path}.map"
1254} 1587}
1255 1588
1256# the temporary/swap location 1589# the temporary/swap location
1257sub save_path { 1590sub save_path {
1258 my ($self) = @_; 1591 my ($self) = @_;
1259 1592
1260 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1593 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1261 sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $path 1594 "$TMPDIR/$path.map"
1262} 1595}
1263 1596
1264# the unique path, undef == no special unique path 1597# the unique path, undef == no special unique path
1265sub uniq_path { 1598sub uniq_path {
1266 my ($self) = @_; 1599 my ($self) = @_;
1267 1600
1268 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1601 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1269 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1602 "$UNIQUEDIR/$path"
1270} 1603}
1271 1604
1272# and all this just because we cannot iterate over 1605# and all this just because we cannot iterate over
1273# all maps in C++... 1606# all maps in C++...
1274sub change_all_map_light { 1607sub change_all_map_light {
1276 1609
1277 $_->change_map_light ($change) 1610 $_->change_map_light ($change)
1278 for grep $_->outdoor, values %cf::MAP; 1611 for grep $_->outdoor, values %cf::MAP;
1279} 1612}
1280 1613
1614sub decay_objects {
1615 my ($self) = @_;
1616
1617 return if $self->{deny_reset};
1618
1619 $self->do_decay_objects;
1620}
1621
1281sub unlink_save { 1622sub unlink_save {
1282 my ($self) = @_; 1623 my ($self) = @_;
1283 1624
1284 utf8::encode (my $save = $self->save_path); 1625 utf8::encode (my $save = $self->save_path);
1285 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1626 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1288 1629
1289sub load_header_from($) { 1630sub load_header_from($) {
1290 my ($self, $path) = @_; 1631 my ($self, $path) = @_;
1291 1632
1292 utf8::encode $path; 1633 utf8::encode $path;
1293 aio_open $path, O_RDONLY, 0 1634 #aio_open $path, O_RDONLY, 0
1294 or return; 1635 # or return;
1295 1636
1296 $self->_load_header ($path) 1637 $self->_load_header ($path)
1297 or return; 1638 or return;
1298 1639
1299 $self->{load_path} = $path; 1640 $self->{load_path} = $path;
1341 $self->load_header_orig 1682 $self->load_header_orig
1342 or return; 1683 or return;
1343 $self->prepare_orig; 1684 $self->prepare_orig;
1344 } 1685 }
1345 1686
1687 $self->{deny_reset} = 1
1688 if $self->no_reset;
1689
1690 $self->default_region (cf::region::find_by_path $self->{path})
1691 unless $self->default_region;
1692
1346 1 1693 1
1347} 1694}
1348 1695
1349sub find; 1696sub find;
1350sub find { 1697sub find {
1362 $map->{last_save} = $cf::RUNTIME; 1709 $map->{last_save} = $cf::RUNTIME;
1363 1710
1364 $map->load_header 1711 $map->load_header
1365 or return; 1712 or return;
1366 1713
1367 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1714 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1368 # doing this can freeze the server in a sync job, obviously 1715 # doing this can freeze the server in a sync job, obviously
1369 #$cf::WAIT_FOR_TICK->wait; 1716 #$cf::WAIT_FOR_TICK->wait;
1370 $map->reset; 1717 $map->reset;
1371 undef $guard; 1718 undef $guard;
1372 return find $path; 1719 return find $path;
1383 my ($self) = @_; 1730 my ($self) = @_;
1384 1731
1385 local $self->{deny_reset} = 1; # loading can take a long time 1732 local $self->{deny_reset} = 1; # loading can take a long time
1386 1733
1387 my $path = $self->{path}; 1734 my $path = $self->{path};
1735
1736 {
1388 my $guard = cf::lock_acquire "map_load:$path"; 1737 my $guard = cf::lock_acquire "map_load:$path";
1389 1738
1390 return if $self->in_memory != cf::MAP_SWAPPED; 1739 return if $self->in_memory != cf::MAP_SWAPPED;
1391 1740
1392 $self->in_memory (cf::MAP_LOADING); 1741 $self->in_memory (cf::MAP_LOADING);
1393 1742
1394 $self->alloc; 1743 $self->alloc;
1395 1744
1396 $self->pre_load; 1745 $self->pre_load;
1397
1398 $self->_load_objects ($self->{load_path}, 1)
1399 or return;
1400
1401 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1402 if delete $self->{load_original};
1403
1404 if (my $uniq = $self->uniq_path) {
1405 utf8::encode $uniq;
1406 if (aio_open $uniq, O_RDONLY, 0) {
1407 $self->clear_unique_items;
1408 $self->_load_objects ($uniq, 0);
1409 }
1410 }
1411
1412 Coro::cede;
1413
1414 # now do the right thing for maps
1415 $self->link_multipart_objects;
1416
1417 unless ($self->{deny_activate}) {
1418 $self->decay_objects;
1419 $self->fix_auto_apply;
1420 $self->update_buttons;
1421 Coro::cede; 1746 Coro::cede;
1422 $self->set_darkness_map; 1747
1748 $self->_load_objects ($self->{load_path}, 1)
1749 or return;
1750
1751 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1752 if delete $self->{load_original};
1753
1754 if (my $uniq = $self->uniq_path) {
1755 utf8::encode $uniq;
1756 if (aio_open $uniq, O_RDONLY, 0) {
1757 $self->clear_unique_items;
1758 $self->_load_objects ($uniq, 0);
1759 }
1760 }
1761
1762 Coro::cede;
1763 # now do the right thing for maps
1764 $self->link_multipart_objects;
1423 $self->difficulty ($self->estimate_difficulty) 1765 $self->difficulty ($self->estimate_difficulty)
1424 unless $self->difficulty; 1766 unless $self->difficulty;
1425 Coro::cede; 1767 Coro::cede;
1768
1769 unless ($self->{deny_activate}) {
1770 $self->decay_objects;
1771 $self->fix_auto_apply;
1772 $self->update_buttons;
1773 Coro::cede;
1774 $self->set_darkness_map;
1775 Coro::cede;
1426 $self->activate; 1776 $self->activate;
1777 }
1778
1779 $self->in_memory (cf::MAP_IN_MEMORY);
1427 } 1780 }
1428 1781
1429 $self->post_load; 1782 $self->post_load;
1430
1431 $self->in_memory (cf::MAP_IN_MEMORY);
1432} 1783}
1433 1784
1434sub customise_for { 1785sub customise_for {
1435 my ($self, $ob) = @_; 1786 my ($self, $ob) = @_;
1436 1787
1437 return find "~" . $ob->name . "/" . $self->{path} 1788 return find "~" . $ob->name . "/" . $self->{path}
1438 if $self->per_player; 1789 if $self->per_player;
1790
1791# return find "?party/" . $ob->name . "/" . $self->{path}
1792# if $self->per_party;
1439 1793
1440 $self 1794 $self
1441} 1795}
1442 1796
1443# find and load all maps in the 3x3 area around a map 1797# find and load all maps in the 3x3 area around a map
1554 1908
1555sub reset_at { 1909sub reset_at {
1556 my ($self) = @_; 1910 my ($self) = @_;
1557 1911
1558 # TODO: safety, remove and allow resettable per-player maps 1912 # TODO: safety, remove and allow resettable per-player maps
1559 return 1e99 if $self->isa ("ext::map_per_player");#d#
1560 return 1e99 if $self->{deny_reset}; 1913 return 1e99 if $self->{deny_reset};
1561 1914
1562 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1915 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1563 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1916 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1564 1917
1575 my ($self) = @_; 1928 my ($self) = @_;
1576 1929
1577 my $lock = cf::lock_acquire "map_data:$self->{path}"; 1930 my $lock = cf::lock_acquire "map_data:$self->{path}";
1578 1931
1579 return if $self->players; 1932 return if $self->players;
1580 return if $self->isa ("ext::map_per_player");#d#
1581 1933
1582 warn "resetting map ", $self->path;#d# 1934 warn "resetting map ", $self->path;
1935
1936 $self->in_memory (cf::MAP_SWAPPED);
1937
1938 # need to save uniques path
1939 unless ($self->{deny_save}) {
1940 my $uniq = $self->uniq_path; utf8::encode $uniq;
1941
1942 $self->_save_objects ($uniq, cf::IO_UNIQUES)
1943 if $uniq;
1944 }
1583 1945
1584 delete $cf::MAP{$self->path}; 1946 delete $cf::MAP{$self->path};
1585 1947
1586 $self->in_memory (cf::MAP_SWAPPED);
1587 $self->clear; 1948 $self->clear;
1588 1949
1589 $_->clear_links_to ($self) for values %cf::MAP; 1950 $_->clear_links_to ($self) for values %cf::MAP;
1590 1951
1591 $self->unlink_save; 1952 $self->unlink_save;
1610 $cf::MAP{$self->path} = $self; 1971 $cf::MAP{$self->path} = $self;
1611 1972
1612 $self->reset; # polite request, might not happen 1973 $self->reset; # polite request, might not happen
1613} 1974}
1614 1975
1976=item $maps = cf::map::tmp_maps
1977
1978Returns an arrayref with all map paths of currently instantiated and saved
1979maps. May block.
1980
1981=cut
1982
1983sub tmp_maps() {
1984 [
1985 map {
1986 utf8::decode $_;
1987 /\.map$/
1988 ? normalise $_
1989 : ()
1990 } @{ aio_readdir $TMPDIR or [] }
1991 ]
1992}
1993
1994=item $maps = cf::map::random_maps
1995
1996Returns an arrayref with all map paths of currently instantiated and saved
1997random maps. May block.
1998
1999=cut
2000
2001sub random_maps() {
2002 [
2003 map {
2004 utf8::decode $_;
2005 /\.map$/
2006 ? normalise "?random/$_"
2007 : ()
2008 } @{ aio_readdir $RANDOMDIR or [] }
2009 ]
2010}
2011
1615=item cf::map::unique_maps 2012=item cf::map::unique_maps
1616 2013
1617Returns an arrayref of paths of all shared maps that have 2014Returns an arrayref of paths of all shared maps that have
1618instantiated unique items. May block. 2015instantiated unique items. May block.
1619 2016
1620=cut 2017=cut
1621 2018
1622sub unique_maps() { 2019sub unique_maps() {
1623 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2020 [
1624 or return; 2021 map {
1625
1626 my @paths;
1627
1628 for (@$files) {
1629 utf8::decode $_; 2022 utf8::decode $_;
1630 next if /\.pst$/;
1631 next unless /^$PATH_SEP/o;
1632
1633 s/\.map$//; 2023 /\.map$/
1634 push @paths, $_; 2024 ? normalise $_
2025 : ()
2026 } @{ aio_readdir $UNIQUEDIR or [] }
1635 } 2027 ]
1636
1637 \@paths
1638} 2028}
1639 2029
1640package cf; 2030package cf;
1641 2031
1642=back 2032=back
1688 2078
1689 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2079 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1690 2080
1691 if ($self->{record_replies}) { 2081 if ($self->{record_replies}) {
1692 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2082 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2083
1693 } else { 2084 } else {
2085 my $pl = $self->contr;
2086
2087 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2088 my $diag = $pl->{npc_dialog};
2089 $diag->{pl}->ext_reply (
2090 $diag->{id},
2091 msgtype => "reply",
2092 msg => $diag->{pl}->expand_cfpod ($msg),
2093 add_topics => []
2094 );
2095
2096 } else {
1694 $msg = $npc->name . " says: $msg" if $npc; 2097 $msg = $npc->name . " says: $msg" if $npc;
1695 $self->message ($msg, $flags); 2098 $self->message ($msg, $flags);
2099 }
1696 } 2100 }
1697} 2101}
1698 2102
1699=item $player_object->may ("access") 2103=item $player_object->may ("access")
1700 2104
1748 $self->deactivate_recursive; 2152 $self->deactivate_recursive;
1749 2153
1750 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2154 return if UNIVERSAL::isa $self->map, "ext::map_link";
1751 2155
1752 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2156 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1753 if $self->map; 2157 if $self->map && $self->map->{path} ne "{link}";
1754 2158
1755 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2159 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1756} 2160}
1757 2161
1758sub cf::object::player::leave_link { 2162sub cf::object::player::leave_link {
1759 my ($self, $map, $x, $y) = @_; 2163 my ($self, $map, $x, $y) = @_;
2164
2165 return unless $self->contr->active;
1760 2166
1761 my $link_pos = delete $self->{_link_pos}; 2167 my $link_pos = delete $self->{_link_pos};
1762 2168
1763 unless ($map) { 2169 unless ($map) {
1764 # restore original map position 2170 # restore original map position
1782 $map->load; 2188 $map->load;
1783 $map->load_diag; 2189 $map->load_diag;
1784 2190
1785 return unless $self->contr->active; 2191 return unless $self->contr->active;
1786 $self->activate_recursive; 2192 $self->activate_recursive;
2193
2194 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1787 $self->enter_map ($map, $x, $y); 2195 $self->enter_map ($map, $x, $y);
1788} 2196}
1789 2197
1790cf::player->attach (
1791 on_logout => sub {
1792 my ($pl) = @_;
1793
1794 # abort map switching before logout
1795 if ($pl->ob->{_link_pos}) {
1796 cf::sync_job {
1797 $pl->ob->leave_link
1798 };
1799 }
1800 },
1801 on_login => sub {
1802 my ($pl) = @_;
1803
1804 # try to abort aborted map switching on player login :)
1805 # should happen only on crashes
1806 if ($pl->ob->{_link_pos}) {
1807 $pl->ob->enter_link;
1808 (async {
1809 # we need this sleep as the login has a concurrent enter_exit running
1810 # and this sleep increases chances of the player not ending up in scorn
1811 $pl->ob->reply (undef,
1812 "There was an internal problem at your last logout, "
1813 . "the server will try to bring you to your intended destination in a second.",
1814 cf::NDI_RED);
1815 Coro::Timer::sleep 1;
1816 $pl->ob->leave_link;
1817 })->prio (2);
1818 }
1819 },
1820);
1821
1822=item $player_object->goto ($path, $x, $y) 2198=item $player_object->goto ($path, $x, $y[, $check->($map)])
1823 2199
2200Moves the player to the given map-path and coordinates by first freezing
2201her, loading and preparing them map, calling the provided $check callback
2202that has to return the map if sucecssful, and then unfreezes the player on
2203the new (success) or old (failed) map position.
2204
1824=cut 2205=cut
2206
2207our $GOTOGEN;
1825 2208
1826sub cf::object::player::goto { 2209sub cf::object::player::goto {
1827 my ($self, $path, $x, $y) = @_; 2210 my ($self, $path, $x, $y, $check) = @_;
2211
2212 # do generation counting so two concurrent goto's will be executed in-order
2213 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1828 2214
1829 $self->enter_link; 2215 $self->enter_link;
1830 2216
1831 (async { 2217 (async {
1832 my $map = eval { 2218 my $map = eval {
1833 my $map = cf::map::find $path; 2219 my $map = cf::map::find $path;
2220
2221 if ($map) {
1834 $map = $map->customise_for ($self) if $map; 2222 $map = $map->customise_for ($self);
2223 $map = $check->($map) if $check && $map;
2224 } else {
2225 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2226 }
2227
1835 $map 2228 $map
2229 };
2230
2231 if ($@) {
2232 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2233 LOG llevError | logBacktrace, Carp::longmess $@;
1836 } or 2234 }
1837 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1838 2235
2236 if ($gen == $self->{_goto_generation}) {
2237 delete $self->{_goto_generation};
1839 $self->leave_link ($map, $x, $y); 2238 $self->leave_link ($map, $x, $y);
2239 }
1840 })->prio (1); 2240 })->prio (1);
1841} 2241}
1842 2242
1843=item $player_object->enter_exit ($exit_object) 2243=item $player_object->enter_exit ($exit_object)
1844 2244
1883 2283
1884 $rmp->{random_seed} ||= $exit->random_seed; 2284 $rmp->{random_seed} ||= $exit->random_seed;
1885 2285
1886 my $data = cf::to_json $rmp; 2286 my $data = cf::to_json $rmp;
1887 my $md5 = Digest::MD5::md5_hex $data; 2287 my $md5 = Digest::MD5::md5_hex $data;
1888 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2288 my $meta = "$RANDOMDIR/$md5.meta";
1889 2289
1890 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2290 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1891 aio_write $fh, 0, (length $data), $data, 0; 2291 aio_write $fh, 0, (length $data), $data, 0;
1892 undef $fh; 2292 undef $fh;
1893 aio_rename "$meta~", $meta; 2293 aio_rename "$meta~", $meta;
1902 2302
1903 return unless $self->type == cf::PLAYER; 2303 return unless $self->type == cf::PLAYER;
1904 2304
1905 if ($exit->slaying eq "/!") { 2305 if ($exit->slaying eq "/!") {
1906 #TODO: this should de-fi-ni-te-ly not be a sync-job 2306 #TODO: this should de-fi-ni-te-ly not be a sync-job
2307 # the problem is that $exit might not survive long enough
2308 # so it needs to be done right now, right here
1907 cf::sync_job { prepare_random_map $exit }; 2309 cf::sync_job { prepare_random_map $exit };
1908 } 2310 }
1909 2311
1910 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2312 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1911 my $hp = $exit->stats->hp; 2313 my $hp = $exit->stats->hp;
1919 $self->goto ($slaying, $hp, $sp); 2321 $self->goto ($slaying, $hp, $sp);
1920 2322
1921 1; 2323 1;
1922 }) { 2324 }) {
1923 $self->message ("Something went wrong deep within the crossfire server. " 2325 $self->message ("Something went wrong deep within the crossfire server. "
1924 . "I'll try to bring you back to the map you were before. " 2326 . "I'll try to bring you back to the map you were before. "
1925 . "Please report this to the dungeon master!", 2327 . "Please report this to the dungeon master!",
1926 cf::NDI_UNIQUE | cf::NDI_RED); 2328 cf::NDI_UNIQUE | cf::NDI_RED);
1927 2329
1928 warn "ERROR in enter_exit: $@"; 2330 warn "ERROR in enter_exit: $@";
1929 $self->leave_link; 2331 $self->leave_link;
1930 } 2332 }
1931 })->prio (1); 2333 })->prio (1);
1944 2346
1945sub cf::client::send_drawinfo { 2347sub cf::client::send_drawinfo {
1946 my ($self, $text, $flags) = @_; 2348 my ($self, $text, $flags) = @_;
1947 2349
1948 utf8::encode $text; 2350 utf8::encode $text;
1949 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2351 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1950} 2352}
1951 2353
2354=item $client->send_msg ($color, $type, $msg, [extra...])
2355
2356Send a drawinfo or msg packet to the client, formatting the msg for the
2357client if neccessary. C<$type> should be a string identifying the type of
2358the message, with C<log> being the default. If C<$color> is negative, suppress
2359the message unless the client supports the msg packet.
2360
2361=cut
2362
2363sub cf::client::send_msg {
2364 my ($self, $color, $type, $msg, @extra) = @_;
2365
2366 $msg = $self->pl->expand_cfpod ($msg);
2367
2368 if ($self->can_msg) {
2369 $self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]);
2370 } else {
2371 # replace some tags by gcfclient-compatible ones
2372 for ($msg) {
2373 1 while
2374 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2375 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2376 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2377 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2378 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${1}[\/color]/;
2379 }
2380
2381 if ($color >= 0) {
2382 if (0 && $msg =~ /\[/) {
2383 $self->send_packet ("drawextinfo $color 4 0 $msg")
2384 } else {
2385 s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2386 $self->send_packet ("drawinfo $color $msg")
2387 }
2388 }
2389 }
2390}
2391
2392=item $client->ext_event ($type, %msg)
2393
2394Sends an exti event to the client.
2395
2396=cut
2397
2398sub cf::client::ext_event($$%) {
2399 my ($self, $type, %msg) = @_;
2400
2401 $msg{msgtype} = "event_$type";
2402 $self->send_packet ("ext " . cf::to_json \%msg);
2403}
1952 2404
1953=item $success = $client->query ($flags, "text", \&cb) 2405=item $success = $client->query ($flags, "text", \&cb)
1954 2406
1955Queues a query to the client, calling the given callback with 2407Queues a query to the client, calling the given callback with
1956the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2408the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1985 # get handled first 2437 # get handled first
1986 my $queue = delete $ns->{query_queue} 2438 my $queue = delete $ns->{query_queue}
1987 or return; # be conservative, not sure how that can happen, but we saw a crash here 2439 or return; # be conservative, not sure how that can happen, but we saw a crash here
1988 2440
1989 (shift @$queue)->[1]->($msg); 2441 (shift @$queue)->[1]->($msg);
2442 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1990 2443
1991 push @{ $ns->{query_queue} }, @$queue; 2444 push @{ $ns->{query_queue} }, @$queue;
1992 2445
1993 if (@{ $ns->{query_queue} } == @$queue) { 2446 if (@{ $ns->{query_queue} } == @$queue) {
1994 if (@$queue) { 2447 if (@$queue) {
2052 2505
2053# here we export the classes and methods available to script code 2506# here we export the classes and methods available to script code
2054 2507
2055=pod 2508=pod
2056 2509
2057The following fucntions and emthods are available within a safe environment: 2510The following functions and methods are available within a safe environment:
2058 2511
2059 cf::object contr pay_amount pay_player map 2512 cf::object contr pay_amount pay_player map
2060 cf::object::player player 2513 cf::object::player player
2061 cf::player peaceful 2514 cf::player peaceful
2062 cf::map trigger 2515 cf::map trigger
2143=back 2596=back
2144 2597
2145=cut 2598=cut
2146 2599
2147############################################################################# 2600#############################################################################
2601# the server's init and main functions
2148 2602
2149=head2 EXTENSION DATABASE SUPPORT 2603sub load_facedata($) {
2604 my ($path) = @_;
2150 2605
2151Crossfire maintains a very simple database for extension use. It can 2606 warn "loading facedata from $path\n";
2152currently store anything that can be serialised using Storable, which
2153excludes objects.
2154 2607
2155The parameter C<$family> should best start with the name of the extension 2608 my $facedata;
2156using it, it should be unique. 2609 0 < aio_load $path, $facedata
2610 or die "$path: $!";
2157 2611
2158=over 4 2612 $facedata = Coro::Storable::thaw $facedata;
2159 2613
2160=item $hashref = cf::db_get $family 2614 $facedata->{version} == 2
2615 or cf::cleanup "$path: version mismatch, cannot proceed.";
2161 2616
2162Return a hashref for use by the extension C<$family>, which can be
2163modified. After modifications, you have to call C<cf::db_dirty> or
2164C<cf::db_sync>.
2165
2166=item $value = cf::db_get $family => $key
2167
2168Returns a single value from the database
2169
2170=item cf::db_put $family => $hashref
2171
2172Stores the given family hashref into the database. Updates are delayed, if
2173you want the data to be synced to disk immediately, use C<cf::db_sync>.
2174
2175=item cf::db_put $family => $key => $value
2176
2177Stores the given C<$value> in the family hash. Updates are delayed, if you
2178want the data to be synced to disk immediately, use C<cf::db_sync>.
2179
2180=item cf::db_dirty
2181
2182Marks the database as dirty, to be updated at a later time.
2183
2184=item cf::db_sync
2185
2186Immediately write the database to disk I<if it is dirty>.
2187
2188=cut
2189
2190our $DB;
2191
2192{
2193 my $path = cf::localdir . "/database.pst";
2194
2195 sub db_load() {
2196 $DB = stat $path ? Storable::retrieve $path : { };
2197 } 2617 {
2618 my $faces = $facedata->{faceinfo};
2198 2619
2199 my $pid; 2620 while (my ($face, $info) = each %$faces) {
2200 2621 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2201 sub db_save() { 2622 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2202 waitpid $pid, 0 if $pid; 2623 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2203 if (0 == ($pid = fork)) { 2624 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2204 $DB->{_meta}{version} = 1; 2625 Coro::cede;
2205 Storable::nstore $DB, "$path~";
2206 rename "$path~", $path;
2207 cf::_exit 0 if defined $pid;
2208 }
2209 }
2210
2211 my $dirty;
2212
2213 sub db_sync() {
2214 db_save if $dirty;
2215 undef $dirty;
2216 }
2217
2218 my $idle = Event->idle (
2219 reentrant => 0,
2220 min => 10,
2221 max => 20,
2222 repeat => 0,
2223 data => WF_AUTOCANCEL,
2224 cb => \&db_sync,
2225 );
2226
2227 sub db_dirty() {
2228 $dirty = 1;
2229 $idle->start;
2230 }
2231
2232 sub db_get($;$) {
2233 @_ >= 2
2234 ? $DB->{$_[0]}{$_[1]}
2235 : ($DB->{$_[0]} ||= { })
2236 }
2237
2238 sub db_put($$;$) {
2239 if (@_ >= 3) {
2240 $DB->{$_[0]}{$_[1]} = $_[2];
2241 } else {
2242 $DB->{$_[0]} = $_[1];
2243 }
2244 db_dirty;
2245 }
2246
2247 cf::global->attach (
2248 prio => 10000,
2249 on_cleanup => sub {
2250 db_sync;
2251 }, 2626 }
2252 );
2253}
2254 2627
2255############################################################################# 2628 while (my ($face, $info) = each %$faces) {
2256# the server's main() 2629 next unless $info->{smooth};
2630 my $idx = cf::face::find $face
2631 or next;
2632 if (my $smooth = cf::face::find $info->{smooth}) {
2633 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2634 } else {
2635 warn "smooth face '$info->{smooth}' not found for face '$face'";
2636 }
2637 Coro::cede;
2638 }
2639 }
2640
2641 {
2642 my $anims = $facedata->{animinfo};
2643
2644 while (my ($anim, $info) = each %$anims) {
2645 cf::anim::set $anim, $info->{frames}, $info->{facings};
2646 Coro::cede;
2647 }
2648
2649 cf::anim::invalidate_all; # d'oh
2650 }
2651
2652 1
2653}
2654
2655sub reload_regions {
2656 load_resource_file "$MAPDIR/regions"
2657 or die "unable to load regions file\n";
2658}
2659
2660sub reload_facedata {
2661 load_facedata "$DATADIR/facedata"
2662 or die "unable to load facedata\n";
2663}
2664
2665sub reload_archetypes {
2666 load_resource_file "$DATADIR/archetypes"
2667 or die "unable to load archetypes\n";
2668}
2669
2670sub reload_treasures {
2671 load_resource_file "$DATADIR/treasures"
2672 or die "unable to load treasurelists\n";
2673}
2674
2675sub reload_resources {
2676 warn "reloading resource files...\n";
2677
2678 reload_regions;
2679 reload_facedata;
2680 #reload_archetypes;#d#
2681 reload_archetypes;
2682 reload_treasures;
2683
2684 warn "finished reloading resource files\n";
2685}
2686
2687sub init {
2688 reload_resources;
2689}
2257 2690
2258sub cfg_load { 2691sub cfg_load {
2259 open my $fh, "<:utf8", cf::confdir . "/config" 2692 open my $fh, "<:utf8", "$CONFDIR/config"
2260 or return; 2693 or return;
2261 2694
2262 local $/; 2695 local $/;
2263 *CFG = YAML::Syck::Load <$fh>; 2696 *CFG = YAML::Syck::Load <$fh>;
2264 2697
2284 Event::one_event; 2717 Event::one_event;
2285 })->prio (Coro::PRIO_MAX); 2718 })->prio (Coro::PRIO_MAX);
2286 }; 2719 };
2287 2720
2288 cfg_load; 2721 cfg_load;
2289 db_load; 2722 db_init;
2290 load_extensions; 2723 load_extensions;
2291 2724
2292 $TICK_WATCHER->start; 2725 $TICK_WATCHER->start;
2293 Event::loop; 2726 Event::loop;
2294} 2727}
2309 }, 2742 },
2310 ); 2743 );
2311 } 2744 }
2312} 2745}
2313 2746
2747sub write_runtime {
2748 my $runtime = "$LOCALDIR/runtime";
2749
2750 # first touch the runtime file to show we are still running:
2751 # the fsync below can take a very very long time.
2752
2753 IO::AIO::aio_utime $runtime, undef, undef;
2754
2755 my $guard = cf::lock_acquire "write_runtime";
2756
2757 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2758 or return;
2759
2760 my $value = $cf::RUNTIME + 90 + 10;
2761 # 10 is the runtime save interval, for a monotonic clock
2762 # 60 allows for the watchdog to kill the server.
2763
2764 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2765 and return;
2766
2767 # always fsync - this file is important
2768 aio_fsync $fh
2769 and return;
2770
2771 # touch it again to show we are up-to-date
2772 aio_utime $fh, undef, undef;
2773
2774 close $fh
2775 or return;
2776
2777 aio_rename "$runtime~", $runtime
2778 and return;
2779
2780 warn "runtime file written.\n";
2781
2782 1
2783}
2784
2314sub emergency_save() { 2785sub emergency_save() {
2315 my $freeze_guard = cf::freeze_mainloop; 2786 my $freeze_guard = cf::freeze_mainloop;
2316 2787
2317 warn "enter emergency perl save\n"; 2788 warn "enter emergency perl save\n";
2318 2789
2333 my $map = $cf::MAP{$path} or next; 2804 my $map = $cf::MAP{$path} or next;
2334 $map->valid or next; 2805 $map->valid or next;
2335 $map->save; 2806 $map->save;
2336 } 2807 }
2337 warn "end emergency map save\n"; 2808 warn "end emergency map save\n";
2809
2810 warn "begin emergency database checkpoint\n";
2811 BDB::db_env_txn_checkpoint $DB_ENV;
2812 warn "end emergency database checkpoint\n";
2338 }; 2813 };
2339 2814
2340 warn "leave emergency perl save\n"; 2815 warn "leave emergency perl save\n";
2341} 2816}
2342 2817
2818sub post_cleanup {
2819 my ($make_core) = @_;
2820
2821 warn Carp::longmess "post_cleanup backtrace"
2822 if $make_core;
2823}
2824
2343sub reload() { 2825sub do_reload_perl() {
2344 # can/must only be called in main 2826 # can/must only be called in main
2345 if ($Coro::current != $Coro::main) { 2827 if ($Coro::current != $Coro::main) {
2346 warn "can only reload from main coroutine"; 2828 warn "can only reload from main coroutine";
2347 return; 2829 return;
2348 } 2830 }
2349 2831
2350 warn "reloading..."; 2832 warn "reloading...";
2351 2833
2352 warn "cancelling server ticker"; 2834 warn "entering sync_job";
2353 $TICK_WATCHER->cancel;
2354 2835
2836 cf::sync_job {
2837 cf::write_runtime; # external watchdog should not bark
2355 cf::emergency_save; 2838 cf::emergency_save;
2839 cf::write_runtime; # external watchdog should not bark
2356 2840
2357 eval { 2841 warn "syncing database to disk";
2842 BDB::db_env_txn_checkpoint $DB_ENV;
2843
2358 # if anything goes wrong in here, we should simply crash as we already saved 2844 # if anything goes wrong in here, we should simply crash as we already saved
2359
2360 warn "syncing database to disk";
2361 cf::db_sync;
2362 2845
2363 warn "cancelling all WF_AUTOCANCEL watchers"; 2846 warn "cancelling all WF_AUTOCANCEL watchers";
2364 for (Event::all_watchers) { 2847 for (Event::all_watchers) {
2365 $_->cancel if $_->data & WF_AUTOCANCEL; 2848 $_->cancel if $_->data & WF_AUTOCANCEL;
2366 } 2849 }
2367 2850
2368 warn "flushing outstanding aio requests"; 2851 warn "flushing outstanding aio requests";
2369 for (;;) { 2852 for (;;) {
2853 BDB::flush;
2370 IO::AIO::flush; 2854 IO::AIO::flush;
2371 Coro::cede; 2855 Coro::cede;
2372 last unless IO::AIO::nreqs; 2856 last unless IO::AIO::nreqs || BDB::nreqs;
2373 warn "iterate..."; 2857 warn "iterate...";
2374 } 2858 }
2859
2860 ++$RELOAD;
2375 2861
2376 warn "cancelling all extension coros"; 2862 warn "cancelling all extension coros";
2377 $_->cancel for values %EXT_CORO; 2863 $_->cancel for values %EXT_CORO;
2378 %EXT_CORO = (); 2864 %EXT_CORO = ();
2379 2865
2419 Symbol::delete_package "safe::$_" 2905 Symbol::delete_package "safe::$_"
2420 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2906 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2421 2907
2422 warn "unloading cf.pm \"a bit\""; 2908 warn "unloading cf.pm \"a bit\"";
2423 delete $INC{"cf.pm"}; 2909 delete $INC{"cf.pm"};
2910 delete $INC{"cf/pod.pm"};
2424 2911
2425 # don't, removes xs symbols, too, 2912 # don't, removes xs symbols, too,
2426 # and global variables created in xs 2913 # and global variables created in xs
2427 #Symbol::delete_package __PACKAGE__; 2914 #Symbol::delete_package __PACKAGE__;
2428 2915
2432 require cf; 2919 require cf;
2433 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2920 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2434 2921
2435 warn "loading config and database again"; 2922 warn "loading config and database again";
2436 cf::cfg_load; 2923 cf::cfg_load;
2437 cf::db_load;
2438 2924
2439 warn "loading extensions"; 2925 warn "loading extensions";
2440 cf::load_extensions; 2926 cf::load_extensions;
2441 2927
2442 warn "reattaching attachments to objects/players"; 2928 warn "reattaching attachments to objects/players";
2443 _global_reattach; 2929 _global_reattach; # objects, sockets
2444 warn "reattaching attachments to maps"; 2930 warn "reattaching attachments to maps";
2445 reattach $_ for values %MAP; 2931 reattach $_ for values %MAP;
2932 warn "reattaching attachments to players";
2933 reattach $_ for values %PLAYER;
2446 2934
2447 warn "restarting server ticker"; 2935 warn "leaving sync_job";
2448 2936
2449 $TICK_WATCHER->start; 2937 1
2450 }; 2938 } or do {
2451
2452 if ($@) {
2453 warn $@; 2939 warn $@;
2454 warn "error while reloading, exiting."; 2940 warn "error while reloading, exiting.";
2455 exit 1; 2941 exit 1;
2456 } 2942 };
2457 2943
2458 warn "reloaded"; 2944 warn "reloaded";
2459}; 2945};
2460 2946
2461our $RELOAD_WATCHER; # used only during reload 2947our $RELOAD_WATCHER; # used only during reload
2462 2948
2949sub reload_perl() {
2950 # doing reload synchronously and two reloads happen back-to-back,
2951 # coro crashes during coro_state_free->destroy here.
2952
2953 $RELOAD_WATCHER ||= Event->timer (
2954 reentrant => 0,
2955 after => 0,
2956 data => WF_AUTOCANCEL,
2957 cb => sub {
2958 do_reload_perl;
2959 undef $RELOAD_WATCHER;
2960 },
2961 );
2962}
2963
2463register_command "reload" => sub { 2964register_command "reload" => sub {
2464 my ($who, $arg) = @_; 2965 my ($who, $arg) = @_;
2465 2966
2466 if ($who->flag (FLAG_WIZ)) { 2967 if ($who->flag (FLAG_WIZ)) {
2467 $who->message ("reloading server."); 2968 $who->message ("reloading server.");
2468 2969 async { reload_perl };
2469 # doing reload synchronously and two reloads happen back-to-back,
2470 # coro crashes during coro_state_free->destroy here.
2471
2472 $RELOAD_WATCHER ||= Event->timer (
2473 reentrant => 0,
2474 after => 0,
2475 data => WF_AUTOCANCEL,
2476 cb => sub {
2477 reload;
2478 undef $RELOAD_WATCHER;
2479 },
2480 );
2481 } 2970 }
2482}; 2971};
2483 2972
2484unshift @INC, $LIBDIR; 2973unshift @INC, $LIBDIR;
2485 2974
2486my $bug_warning = 0; 2975my $bug_warning = 0;
2487 2976
2977our @WAIT_FOR_TICK;
2978our @WAIT_FOR_TICK_BEGIN;
2979
2980sub wait_for_tick {
2981 return unless $TICK_WATCHER->is_active;
2982 return if $Coro::current == $Coro::main;
2983
2984 my $signal = new Coro::Signal;
2985 push @WAIT_FOR_TICK, $signal;
2986 $signal->wait;
2987}
2988
2989sub wait_for_tick_begin {
2990 return unless $TICK_WATCHER->is_active;
2991 return if $Coro::current == $Coro::main;
2992
2993 my $signal = new Coro::Signal;
2994 push @WAIT_FOR_TICK_BEGIN, $signal;
2995 $signal->wait;
2996}
2997
2998 my $min = 1e6;#d#
2999 my $avg = 10;
2488$TICK_WATCHER = Event->timer ( 3000$TICK_WATCHER = Event->timer (
2489 reentrant => 0, 3001 reentrant => 0,
2490 parked => 1, 3002 parked => 1,
2491 prio => 0, 3003 prio => 0,
2492 at => $NEXT_TICK || $TICK, 3004 at => $NEXT_TICK || $TICK,
2496 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3008 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2497 unless ++$bug_warning > 10; 3009 unless ++$bug_warning > 10;
2498 return; 3010 return;
2499 } 3011 }
2500 3012
2501 $NOW = Event::time; 3013 $NOW = $tick_start = Event::time;
2502 3014
2503 cf::server_tick; # one server iteration 3015 cf::server_tick; # one server iteration
3016
3017 0 && sync_job {#d#
3018 for(1..10) {
3019 my $t = Event::time;
3020 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3021 or die;
3022
3023 $map->width (50);
3024 $map->height (50);
3025 $map->alloc;
3026 $map->_load_objects ("/tmp/x.map", 1);
3027 my $t = Event::time - $t;
3028
3029 #next unless $t < 0.0013;#d#
3030 if ($t < $min) {
3031 $min = $t;
3032 }
3033 $avg = $avg * 0.99 + $t * 0.01;
3034 }
3035 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3036 exit 0;
3037 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3038 };
3039
2504 $RUNTIME += $TICK; 3040 $RUNTIME += $TICK;
2505 $NEXT_TICK += $TICK; 3041 $NEXT_TICK += $TICK;
2506 3042
2507 $WAIT_FOR_TICK->broadcast; 3043 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2508 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited; 3044 $NEXT_RUNTIME_WRITE = $NOW + 10;
2509 3045 Coro::async_pool {
2510 Event::sweep; 3046 write_runtime
2511 Coro::cede_notself; 3047 or warn "ERROR: unable to write runtime file: $!";
3048 };
2512 3049 }
3050
2513# my $AFTER = Event::time; 3051# my $AFTER = Event::time;
2514# warn $AFTER - $NOW;#d# 3052# warn $AFTER - $NOW;#d#
2515 3053
3054 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3055 $sig->send;
3056 }
3057 while (my $sig = shift @WAIT_FOR_TICK) {
3058 $sig->send;
3059 }
3060
3061 $NOW = Event::time;
3062
2516 # if we are delayed by four ticks or more, skip them all 3063 # if we are delayed by four ticks or more, skip them all
2517 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3064 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2518 3065
2519 $TICK_WATCHER->at ($NEXT_TICK); 3066 $TICK_WATCHER->at ($NEXT_TICK);
2520 $TICK_WATCHER->start; 3067 $TICK_WATCHER->start;
3068
3069 $LOAD = ($NOW - $tick_start) / $TICK;
3070 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3071
3072 _post_tick;
3073
3074
2521 }, 3075 },
2522); 3076);
2523 3077
3078{
3079 BDB::max_poll_time $TICK * 0.1;
3080 $BDB_POLL_WATCHER = Event->io (
3081 reentrant => 0,
3082 fd => BDB::poll_fileno,
3083 poll => 'r',
3084 prio => 0,
3085 data => WF_AUTOCANCEL,
3086 cb => \&BDB::poll_cb,
3087 );
3088 BDB::min_parallel 8;
3089
3090 BDB::set_sync_prepare {
3091 my $status;
3092 my $current = $Coro::current;
3093 (
3094 sub {
3095 $status = $!;
3096 $current->ready; undef $current;
3097 },
3098 sub {
3099 Coro::schedule while defined $current;
3100 $! = $status;
3101 },
3102 )
3103 };
3104
3105 unless ($DB_ENV) {
3106 $DB_ENV = BDB::db_env_create;
3107
3108 cf::sync_job {
3109 eval {
3110 BDB::db_env_open
3111 $DB_ENV,
3112 $BDBDIR,
3113 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3114 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3115 0666;
3116
3117 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3118
3119 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3120 $DB_ENV->set_lk_detect;
3121 };
3122
3123 cf::cleanup "db_env_open(db): $@" if $@;
3124 };
3125 }
3126}
3127
3128{
3129 IO::AIO::min_parallel 8;
3130
3131 undef $Coro::AIO::WATCHER;
2524IO::AIO::max_poll_time $TICK * 0.1; 3132 IO::AIO::max_poll_time $TICK * 0.1;
2525
2526undef $Coro::AIO::WATCHER;
2527$AIO_POLL_WATCHER = Event->io ( 3133 $AIO_POLL_WATCHER = Event->io (
2528 reentrant => 0, 3134 reentrant => 0,
3135 data => WF_AUTOCANCEL,
2529 fd => IO::AIO::poll_fileno, 3136 fd => IO::AIO::poll_fileno,
2530 poll => 'r', 3137 poll => 'r',
2531 prio => 6, 3138 prio => 6,
2532 data => WF_AUTOCANCEL,
2533 cb => \&IO::AIO::poll_cb, 3139 cb => \&IO::AIO::poll_cb,
2534); 3140 );
3141}
2535 3142
2536$WRITE_RUNTIME_WATCHER = Event->timer ( 3143my $_log_backtrace;
2537 reentrant => 0, 3144
2538 data => WF_AUTOCANCEL, 3145sub _log_backtrace {
2539 after => 1, 3146 my ($msg, @addr) = @_;
2540 interval => 10, 3147
2541 prio => 6, # keep it lowest so it acts like a watchdog 3148 $msg =~ s/\n//;
2542 cb => Coro::unblock_sub { 3149
2543 write_runtime 3150 # limit the # of concurrent backtraces
2544 or warn "ERROR: unable to write runtime file: $!"; 3151 if ($_log_backtrace < 2) {
3152 ++$_log_backtrace;
3153 async {
3154 my @bt = fork_call {
3155 @addr = map { sprintf "%x", $_ } @addr;
3156 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3157 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3158 or die "addr2line: $!";
3159
3160 my @funcs;
3161 my @res = <$fh>;
3162 chomp for @res;
3163 while (@res) {
3164 my ($func, $line) = splice @res, 0, 2, ();
3165 push @funcs, "[$func] $line";
3166 }
3167
3168 @funcs
3169 };
3170
3171 LOG llevInfo, "[ABT] $msg\n";
3172 LOG llevInfo, "[ABT] $_\n" for @bt;
3173 --$_log_backtrace;
3174 };
3175 } else {
3176 LOG llevInfo, "[ABT] $msg\n";
3177 LOG llevInfo, "[ABT] [suppressed]\n";
2545 }, 3178 }
2546); 3179}
3180
3181# load additional modules
3182use cf::pod;
2547 3183
2548END { cf::emergency_save } 3184END { cf::emergency_save }
2549 3185
25501 31861
2551 3187

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines