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.166 by root, Sat Jan 13 23:06:13 2007 UTC vs.
Revision 1.313 by root, Sun Jul 22 14:17:58 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.3 (); 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 ();
26use BDB ();
20use Data::Dumper; 27use Data::Dumper;
21use Digest::MD5; 28use Digest::MD5;
22use Fcntl; 29use Fcntl;
30use YAML::Syck ();
23use IO::AIO 2.32 (); 31use IO::AIO 2.32 ();
24use YAML::Syck ();
25use Time::HiRes; 32use Time::HiRes;
33use Compress::LZF;
34use Digest::MD5 ();
26 35
36# configure various modules to our taste
37#
38$Storable::canonical = 1; # reduce rsync transfers
39Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
40Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
41
27use Event; $Event::Eval = 1; # no idea why this is required, but it is 42$Event::Eval = 1; # no idea why this is required, but it is
28
29sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
30 43
31# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 44# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
32$YAML::Syck::ImplicitUnicode = 1; 45$YAML::Syck::ImplicitUnicode = 1;
33 46
34$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 47$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
35 48
49sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
50
36our %COMMAND = (); 51our %COMMAND = ();
37our %COMMAND_TIME = (); 52our %COMMAND_TIME = ();
38 53
39our @EXTS = (); # list of extension package names 54our @EXTS = (); # list of extension package names
40our %EXTCMD = (); 55our %EXTCMD = ();
56our %EXTICMD = ();
41our %EXT_CORO = (); # coroutines bound to extensions 57our %EXT_CORO = (); # coroutines bound to extensions
42our %EXT_MAP = (); # pluggable maps 58our %EXT_MAP = (); # pluggable maps
43 59
60our $RELOAD; # number of reloads so far
44our @EVENT; 61our @EVENT;
45our $LIBDIR = datadir . "/ext";
46 62
47our $TICK = MAX_TIME * 1e-6; 63our $CONFDIR = confdir;
64our $DATADIR = datadir;
65our $LIBDIR = "$DATADIR/ext";
66our $PODDIR = "$DATADIR/pod";
67our $MAPDIR = "$DATADIR/" . mapdir;
68our $LOCALDIR = localdir;
69our $TMPDIR = "$LOCALDIR/" . tmpdir;
70our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
71our $PLAYERDIR = "$LOCALDIR/" . playerdir;
72our $RANDOMDIR = "$LOCALDIR/random";
73our $BDBDIR = "$LOCALDIR/db";
74
75our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
48our $TICK_WATCHER; 76our $TICK_WATCHER;
77our $AIO_POLL_WATCHER;
78our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
49our $NEXT_TICK; 79our $NEXT_TICK;
50our $NOW; 80our $NOW;
81our $USE_FSYNC = 1; # use fsync to write maps - default off
82
83our $BDB_POLL_WATCHER;
84our $DB_ENV;
51 85
52our %CFG; 86our %CFG;
53 87
54our $UPTIME; $UPTIME ||= time; 88our $UPTIME; $UPTIME ||= time;
55our $RUNTIME; 89our $RUNTIME;
56 90
57our %PLAYER; # all users 91our %PLAYER; # all users
58our %MAP; # all maps 92our %MAP; # all maps
59our $LINK_MAP; # the special {link} map, which is always available 93our $LINK_MAP; # the special {link} map, which is always available
60our $RANDOM_MAPS = cf::localdir . "/random";
61
62our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
63our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
64 94
65# used to convert map paths into valid unix filenames by replacing / by ∕ 95# used to convert map paths into valid unix filenames by replacing / by ∕
66our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 96our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
67 97
98our $LOAD; # a number between 0 (idle) and 1 (too many objects)
99our $LOADAVG; # same thing, but with alpha-smoothing
100our $tick_start; # for load detecting purposes
101
68binmode STDOUT; 102binmode STDOUT;
69binmode STDERR; 103binmode STDERR;
70 104
71# read virtual server time, if available 105# read virtual server time, if available
72unless ($RUNTIME || !-e cf::localdir . "/runtime") { 106unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
73 open my $fh, "<", cf::localdir . "/runtime" 107 open my $fh, "<", "$LOCALDIR/runtime"
74 or die "unable to read runtime file: $!"; 108 or die "unable to read runtime file: $!";
75 $RUNTIME = <$fh> + 0.; 109 $RUNTIME = <$fh> + 0.;
76} 110}
77 111
78mkdir cf::localdir; 112mkdir $_
79mkdir cf::localdir . "/" . cf::playerdir; 113 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
80mkdir cf::localdir . "/" . cf::tmpdir;
81mkdir cf::localdir . "/" . cf::uniquedir;
82mkdir $RANDOM_MAPS;
83 114
84our $EMERGENCY_POSITION; 115our $EMERGENCY_POSITION;
116
117sub cf::map::normalise;
85 118
86############################################################################# 119#############################################################################
87 120
88=head2 GLOBAL VARIABLES 121=head2 GLOBAL VARIABLES
89 122
… …
96=item $cf::RUNTIME 129=item $cf::RUNTIME
97 130
98The time this server has run, starts at 0 and is increased by $cf::TICK on 131The time this server has run, starts at 0 and is increased by $cf::TICK on
99every server tick. 132every server tick.
100 133
101=item $cf::LIBDIR 134=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
135$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
136$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
102 137
103The perl library directory, where extensions and cf-specific modules can 138Various directories - "/etc", read-only install directory, perl-library
104be found. It will be added to C<@INC> automatically. 139directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
140unique-items directory, player file directory, random maps directory and
141database environment.
105 142
106=item $cf::NOW 143=item $cf::NOW
107 144
108The time of the last (current) server tick. 145The time of the last (current) server tick.
109 146
110=item $cf::TICK 147=item $cf::TICK
111 148
112The interval between server ticks, in seconds. 149The interval between server ticks, in seconds.
150
151=item $cf::LOADAVG
152
153The current CPU load on the server (alpha-smoothed), as a value between 0
154(none) and 1 (overloaded), indicating how much time is spent on processing
155objects per tick. Healthy values are < 0.5.
156
157=item $cf::LOAD
158
159The raw value load value from the last tick.
113 160
114=item %cf::CFG 161=item %cf::CFG
115 162
116Configuration for the server, loaded from C</etc/crossfire/config>, or 163Configuration for the server, loaded from C</etc/crossfire/config>, or
117from wherever your confdir points to. 164from wherever your confdir points to.
118 165
119=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 166=item cf::wait_for_tick, cf::wait_for_tick_begin
120 167
121These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK) 168These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
122or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick 169returns directly I<after> the tick processing (and consequently, can only wake one process
123processing has been done. Call C<< ->wait >> on them to maximise the 170per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
124window of cpu time available, or simply to synchronise to the server tick. 171
172=item @cf::INVOKE_RESULTS
173
174This array contains the results of the last C<invoke ()> call. When
175C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
176that call.
125 177
126=back 178=back
127 179
128=cut 180=cut
129 181
130BEGIN { 182BEGIN {
131 *CORE::GLOBAL::warn = sub { 183 *CORE::GLOBAL::warn = sub {
132 my $msg = join "", @_; 184 my $msg = join "", @_;
133 utf8::encode $msg;
134 185
135 $msg .= "\n" 186 $msg .= "\n"
136 unless $msg =~ /\n$/; 187 unless $msg =~ /\n$/;
137 188
189 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
190
191 utf8::encode $msg;
138 LOG llevError, $msg; 192 LOG llevError, $msg;
139 }; 193 };
140} 194}
141 195
142@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 196@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
143@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 197@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
144@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 198@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
145@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 199@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
146@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 200@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
201@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
147@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 202@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
148 203
149# we bless all objects into (empty) derived classes to force a method lookup 204# we bless all objects into (empty) derived classes to force a method lookup
150# within the Safe compartment. 205# within the Safe compartment.
151for my $pkg (qw( 206for my $pkg (qw(
152 cf::global cf::attachable 207 cf::global cf::attachable
… …
160} 215}
161 216
162$Event::DIED = sub { 217$Event::DIED = sub {
163 warn "error in event callback: @_"; 218 warn "error in event callback: @_";
164}; 219};
220
221#############################################################################
165 222
166=head2 UTILITY FUNCTIONS 223=head2 UTILITY FUNCTIONS
167 224
168=over 4 225=over 4
169 226
… …
188 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 245 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
189 $d 246 $d
190 } || "[unable to dump $_[0]: '$@']"; 247 } || "[unable to dump $_[0]: '$@']";
191} 248}
192 249
193use JSON::Syck (); # TODO# replace by JSON::PC once working
194
195=item $ref = cf::from_json $json 250=item $ref = cf::from_json $json
196 251
197Converts a JSON string into the corresponding perl data structure. 252Converts a JSON string into the corresponding perl data structure.
198 253
199=cut
200
201sub from_json($) {
202 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
203 JSON::Syck::Load $_[0]
204}
205
206=item $json = cf::to_json $ref 254=item $json = cf::to_json $ref
207 255
208Converts a perl data structure into its JSON representation. 256Converts a perl data structure into its JSON representation.
209 257
210=cut 258=cut
211 259
212sub to_json($) { 260our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
213 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 261
214 JSON::Syck::Dump $_[0] 262sub to_json ($) { $json_coder->encode ($_[0]) }
215} 263sub from_json ($) { $json_coder->decode ($_[0]) }
216 264
217=item cf::lock_wait $string 265=item cf::lock_wait $string
218 266
219Wait until the given lock is available. See cf::lock_acquire. 267Wait until the given lock is available. See cf::lock_acquire.
220 268
… …
226returned. 274returned.
227 275
228Lock names should begin with a unique identifier (for example, cf::map::find 276Lock names should begin with a unique identifier (for example, cf::map::find
229uses map_find and cf::map::load uses map_load). 277uses map_find and cf::map::load uses map_load).
230 278
279=item $locked = cf::lock_active $string
280
281Return true if the lock is currently active, i.e. somebody has locked it.
282
231=cut 283=cut
232 284
233our %LOCK; 285our %LOCK;
234 286
235sub lock_wait($) { 287sub lock_wait($) {
… …
254 # wake up all waiters, to be on the safe side 306 # wake up all waiters, to be on the safe side
255 $_->ready for @{ delete $LOCK{$key} }; 307 $_->ready for @{ delete $LOCK{$key} };
256 } 308 }
257} 309}
258 310
311sub lock_active($) {
312 my ($key) = @_;
313
314 ! ! $LOCK{$key}
315}
316
259sub freeze_mainloop { 317sub freeze_mainloop {
260 return unless $TICK_WATCHER->is_active; 318 return unless $TICK_WATCHER->is_active;
261 319
262 my $guard = Coro::guard { $TICK_WATCHER->start }; 320 my $guard = Coro::guard {
321 $TICK_WATCHER->start;
322 };
263 $TICK_WATCHER->stop; 323 $TICK_WATCHER->stop;
264 $guard 324 $guard
265} 325}
266 326
267=item cf::async { BLOCK } 327=item cf::async { BLOCK }
… …
274 334
275BEGIN { *async = \&Coro::async_pool } 335BEGIN { *async = \&Coro::async_pool }
276 336
277=item cf::sync_job { BLOCK } 337=item cf::sync_job { BLOCK }
278 338
279The design of crossfire+ requires that the main coro ($Coro::main) is 339The design of Crossfire TRT requires that the main coroutine ($Coro::main)
280always able to handle events or runnable, as crossfire+ is only partly 340is always able to handle events or runnable, as Crossfire TRT is only
281reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 341partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
342acceptable.
282 343
283If it must be done, put the blocking parts into C<sync_job>. This will run 344If it must be done, put the blocking parts into C<sync_job>. This will run
284the given BLOCK in another coroutine while waiting for the result. The 345the given BLOCK in another coroutine while waiting for the result. The
285server will be frozen during this time, so the block should either finish 346server will be frozen during this time, so the block should either finish
286fast or be very important. 347fast or be very important.
… …
289 350
290sub sync_job(&) { 351sub sync_job(&) {
291 my ($job) = @_; 352 my ($job) = @_;
292 353
293 if ($Coro::current == $Coro::main) { 354 if ($Coro::current == $Coro::main) {
355 my $time = Event::time;
356
294 # this is the main coro, too bad, we have to block 357 # this is the main coro, too bad, we have to block
295 # till the operation succeeds, freezing the server :/ 358 # till the operation succeeds, freezing the server :/
296 359
297 # TODO: use suspend/resume instead 360 # TODO: use suspend/resume instead
298 # (but this is cancel-safe) 361 # (but this is cancel-safe)
… …
309 372
310 while ($busy) { 373 while ($busy) {
311 Coro::cede or Event::one_event; 374 Coro::cede or Event::one_event;
312 } 375 }
313 376
377 $time = Event::time - $time;
378
379 LOG llevError | logBacktrace, Carp::longmess "long sync job"
380 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
381
382 $tick_start += $time; # do not account sync jobs to server load
383
314 wantarray ? @res : $res[0] 384 wantarray ? @res : $res[0]
315 } else { 385 } else {
316 # we are in another coroutine, how wonderful, everything just works 386 # we are in another coroutine, how wonderful, everything just works
317 387
318 $job->() 388 $job->()
… …
337 $EXT_CORO{$coro+0} = $coro; 407 $EXT_CORO{$coro+0} = $coro;
338 408
339 $coro 409 $coro
340} 410}
341 411
342sub write_runtime { 412=item fork_call { }, $args
343 return unless $TICK_WATCHER->is_active;
344 413
345 my $runtime = cf::localdir . "/runtime"; 414Executes the given code block with the given arguments in a seperate
415process, returning the results. Everything must be serialisable with
416Coro::Storable. May, of course, block. Note that the executed sub may
417never block itself or use any form of Event handling.
346 418
347 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 419=cut
348 or return;
349 420
350 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock 421sub _store_scalar {
351 (aio_write $fh, 0, (length $value), $value, 0) <= 0 422 open my $fh, ">", \my $buf
352 and return; 423 or die "fork_call: cannot open fh-to-buf in child : $!";
353 424 Storable::store_fd $_[0], $fh;
354 aio_fsync $fh
355 and return;
356
357 close $fh 425 close $fh;
358 or return;
359 426
360 aio_rename "$runtime~", $runtime 427 $buf
361 and return; 428}
362 429
430sub fork_call(&@) {
431 my ($cb, @args) = @_;
432
433# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
434# or die "socketpair: $!";
435 pipe my $fh1, my $fh2
436 or die "pipe: $!";
437
438 if (my $pid = fork) {
439 close $fh2;
440
441 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
442 warn "pst<$res>" unless $res =~ /^pst/;
443 $res = Coro::Storable::thaw $res;
444
445 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
446
447 Carp::confess $$res unless "ARRAY" eq ref $res;
448
449 return wantarray ? @$res : $res->[-1];
450 } else {
451 reset_signals;
452 local $SIG{__WARN__};
453 local $SIG{__DIE__};
454 # just in case, this hack effectively disables event
455 # in the child. cleaner and slower would be canceling all watchers,
456 # but this works for the time being.
457 local $Coro::idle;
458 $Coro::current->prio (Coro::PRIO_MAX);
459
460 eval {
461 close $fh1;
462
463 my @res = eval { $cb->(@args) };
464
465 syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
466 close $fh2;
467 };
468
469 warn $@ if $@;
470 _exit 0;
363 1 471 }
472}
473
474=item $value = cf::db_get $family => $key
475
476Returns a single value from the environment database.
477
478=item cf::db_put $family => $key => $value
479
480Stores the given C<$value> in the family. It can currently store binary
481data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
482
483=cut
484
485our $DB;
486
487sub db_init {
488 unless ($DB) {
489 $DB = BDB::db_create $DB_ENV;
490
491 cf::sync_job {
492 eval {
493 $DB->set_flags (BDB::CHKSUM);
494
495 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
496 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
497 cf::cleanup "db_open(db): $!" if $!;
498 };
499 cf::cleanup "db_open(db): $@" if $@;
500 };
501 }
502}
503
504sub db_get($$) {
505 my $key = "$_[0]/$_[1]";
506
507 cf::sync_job {
508 BDB::db_get $DB, undef, $key, my $data;
509
510 $! ? ()
511 : $data
512 }
513}
514
515sub db_put($$$) {
516 BDB::dbreq_pri 4;
517 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
518}
519
520=item cf::cache $id => [$paths...], $processversion => $process
521
522Generic caching function that returns the value of the resource $id,
523caching and regenerating as required.
524
525This function can block.
526
527=cut
528
529sub cache {
530 my ($id, $src, $processversion, $process) = @_;
531
532 my $meta =
533 join "\x00",
534 $processversion,
535 map {
536 aio_stat $_
537 and Carp::croak "$_: $!";
538
539 ($_, (stat _)[7,9])
540 } @$src;
541
542 my $dbmeta = db_get cache => "$id/meta";
543 if ($dbmeta ne $meta) {
544 # changed, we may need to process
545
546 my @data;
547 my $md5;
548
549 for (0 .. $#$src) {
550 0 <= aio_load $src->[$_], $data[$_]
551 or Carp::croak "$src->[$_]: $!";
552 }
553
554 # if processing is expensive, check
555 # checksum first
556 if (1) {
557 $md5 =
558 join "\x00",
559 $processversion,
560 map {
561 Coro::cede;
562 ($src->[$_], Digest::MD5::md5_hex $data[$_])
563 } 0.. $#$src;
564
565
566 my $dbmd5 = db_get cache => "$id/md5";
567 if ($dbmd5 eq $md5) {
568 db_put cache => "$id/meta", $meta;
569
570 return db_get cache => "$id/data";
571 }
572 }
573
574 my $t1 = Time::HiRes::time;
575 my $data = $process->(\@data);
576 my $t2 = Time::HiRes::time;
577
578 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
579
580 db_put cache => "$id/data", $data;
581 db_put cache => "$id/md5" , $md5;
582 db_put cache => "$id/meta", $meta;
583
584 return $data;
585 }
586
587 db_get cache => "$id/data"
588}
589
590=item cf::datalog type => key => value, ...
591
592Log a datalog packet of the given type with the given key-value pairs.
593
594=cut
595
596sub datalog($@) {
597 my ($type, %kv) = @_;
598 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
364} 599}
365 600
366=back 601=back
367 602
368=cut 603=cut
… …
375attach callbacks/event handlers (a collection of which is called an "attachment") 610attach callbacks/event handlers (a collection of which is called an "attachment")
376to it. All such attachable objects support the following methods. 611to it. All such attachable objects support the following methods.
377 612
378In the following description, CLASS can be any of C<global>, C<object> 613In the following description, CLASS can be any of C<global>, C<object>
379C<player>, C<client> or C<map> (i.e. the attachable objects in 614C<player>, C<client> or C<map> (i.e. the attachable objects in
380crossfire+). 615Crossfire TRT).
381 616
382=over 4 617=over 4
383 618
384=item $attachable->attach ($attachment, key => $value...) 619=item $attachable->attach ($attachment, key => $value...)
385 620
… …
499our @CB_TYPE = (); # registry for type (cf-object class) based events 734our @CB_TYPE = (); # registry for type (cf-object class) based events
500our @CB_MAP = (); 735our @CB_MAP = ();
501 736
502my %attachment; 737my %attachment;
503 738
739sub cf::attachable::thawer_merge {
740 # simply override everything except _meta
741 local $_[0]{_meta};
742 %{$_[0]} = %{$_[1]};
743}
744
504sub _attach_cb($$$$) { 745sub _attach_cb($$$$) {
505 my ($registry, $event, $prio, $cb) = @_; 746 my ($registry, $event, $prio, $cb) = @_;
506 747
507 use sort 'stable'; 748 use sort 'stable';
508 749
… …
542 $registry = $CB_TYPE[$object_type] ||= []; 783 $registry = $CB_TYPE[$object_type] ||= [];
543 784
544 } elsif ($type eq "subtype") { 785 } elsif ($type eq "subtype") {
545 defined $object_type or Carp::croak "subtype specified without type"; 786 defined $object_type or Carp::croak "subtype specified without type";
546 my $object_subtype = shift @arg; 787 my $object_subtype = shift @arg;
547 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 788 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
548 789
549 } elsif ($type eq "package") { 790 } elsif ($type eq "package") {
550 my $pkg = shift @arg; 791 my $pkg = shift @arg;
551 792
552 while (my ($name, $id) = each %cb_id) { 793 while (my ($name, $id) = each %cb_id) {
… …
581 _attach $registry, $klass, @attach; 822 _attach $registry, $klass, @attach;
582 } 823 }
583 824
584 $obj->{$name} = \%arg; 825 $obj->{$name} = \%arg;
585 } else { 826 } else {
586 warn "object uses attachment '$name' that is not available, postponing.\n"; 827 warn "object uses attachment '$name' which is not available, postponing.\n";
587 } 828 }
588 829
589 $obj->{_attachment}{$name} = undef; 830 $obj->{_attachment}{$name} = undef;
590} 831}
591 832
… …
593 if (ref $_[0]) { 834 if (ref $_[0]) {
594 _object_attach @_; 835 _object_attach @_;
595 } else { 836 } else {
596 _attach shift->_attach_registry, @_; 837 _attach shift->_attach_registry, @_;
597 } 838 }
839 _recalc_want;
598}; 840};
599 841
600# all those should be optimised 842# all those should be optimised
601sub cf::attachable::detach { 843sub cf::attachable::detach {
602 my ($obj, $name) = @_; 844 my ($obj, $name) = @_;
… …
605 delete $obj->{_attachment}{$name}; 847 delete $obj->{_attachment}{$name};
606 reattach ($obj); 848 reattach ($obj);
607 } else { 849 } else {
608 Carp::croak "cannot, currently, detach class attachments"; 850 Carp::croak "cannot, currently, detach class attachments";
609 } 851 }
852 _recalc_want;
610}; 853};
611 854
612sub cf::attachable::attached { 855sub cf::attachable::attached {
613 my ($obj, $name) = @_; 856 my ($obj, $name) = @_;
614 857
… …
629 "; 872 ";
630 die if $@; 873 die if $@;
631} 874}
632 875
633our $override; 876our $override;
634our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 877our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
635 878
636sub override { 879sub override {
637 $override = 1; 880 $override = 1;
638 @invoke_results = (); 881 @INVOKE_RESULTS = (@_);
639} 882}
640 883
641sub do_invoke { 884sub do_invoke {
642 my $event = shift; 885 my $event = shift;
643 my $callbacks = shift; 886 my $callbacks = shift;
644 887
645 @invoke_results = (); 888 @INVOKE_RESULTS = ();
646 889
647 local $override; 890 local $override;
648 891
649 for (@$callbacks) { 892 for (@$callbacks) {
650 eval { &{$_->[1]} }; 893 eval { &{$_->[1]} };
… …
667 910
668Generate an object-specific event with the given arguments. 911Generate an object-specific event with the given arguments.
669 912
670This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 913This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
671removed in future versions), and there is no public API to access override 914removed in future versions), and there is no public API to access override
672results (if you must, access C<@cf::invoke_results> directly). 915results (if you must, access C<@cf::INVOKE_RESULTS> directly).
673 916
674=back 917=back
675 918
676=cut 919=cut
677 920
678############################################################################# 921#############################################################################
679# object support 922# object support
923#
924
925sub _can_merge {
926 my ($ob1, $ob2) = @_;
927
928 local $Storable::canonical = 1;
929 my $fob1 = Storable::freeze $ob1;
930 my $fob2 = Storable::freeze $ob2;
931
932 $fob1 eq $fob2
933}
680 934
681sub reattach { 935sub reattach {
682 # basically do the same as instantiate, without calling instantiate 936 # basically do the same as instantiate, without calling instantiate
683 my ($obj) = @_; 937 my ($obj) = @_;
938
939 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
684 940
685 my $registry = $obj->registry; 941 my $registry = $obj->registry;
686 942
687 @$registry = (); 943 @$registry = ();
688 944
… …
735 $filename, length $$rdata, scalar @$objs; 991 $filename, length $$rdata, scalar @$objs;
736 992
737 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 993 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
738 chmod SAVE_MODE, $fh; 994 chmod SAVE_MODE, $fh;
739 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 995 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
740 aio_fsync $fh; 996 aio_fsync $fh if $cf::USE_FSYNC;
741 close $fh; 997 close $fh;
742 998
743 if (@$objs) { 999 if (@$objs) {
744 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1000 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
745 chmod SAVE_MODE, $fh; 1001 chmod SAVE_MODE, $fh;
746 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1002 my $data = Storable::nfreeze { version => 1, objs => $objs };
747 aio_write $fh, 0, (length $data), $data, 0; 1003 aio_write $fh, 0, (length $data), $data, 0;
748 aio_fsync $fh; 1004 aio_fsync $fh if $cf::USE_FSYNC;
749 close $fh; 1005 close $fh;
750 aio_rename "$filename.pst~", "$filename.pst"; 1006 aio_rename "$filename.pst~", "$filename.pst";
751 } 1007 }
752 } else { 1008 } else {
753 aio_unlink "$filename.pst"; 1009 aio_unlink "$filename.pst";
… …
785 or return; 1041 or return;
786 $av = eval { (Storable::thaw $av)->{objs} }; 1042 $av = eval { (Storable::thaw $av)->{objs} };
787 } 1043 }
788 1044
789 warn sprintf "loading %s (%d)\n", 1045 warn sprintf "loading %s (%d)\n",
790 $filename, length $data, scalar @{$av || []};#d# 1046 $filename, length $data, scalar @{$av || []};
791 return ($data, $av); 1047 return ($data, $av);
792} 1048}
1049
1050=head2 COMMAND CALLBACKS
1051
1052=over 4
1053
1054=cut
793 1055
794############################################################################# 1056#############################################################################
795# command handling &c 1057# command handling &c
796 1058
797=item cf::register_command $name => \&callback($ob,$args); 1059=item cf::register_command $name => \&callback($ob,$args);
… …
810 push @{ $COMMAND{$name} }, [$caller, $cb]; 1072 push @{ $COMMAND{$name} }, [$caller, $cb];
811} 1073}
812 1074
813=item cf::register_extcmd $name => \&callback($pl,$packet); 1075=item cf::register_extcmd $name => \&callback($pl,$packet);
814 1076
815Register a callbackf ro execution when the client sends an extcmd packet. 1077Register a callback for execution when the client sends an (synchronous)
1078extcmd packet. Ext commands will be processed in the order they are
1079received by the server, like other user commands. The first argument is
1080the logged-in player. Ext commands can only be processed after a player
1081has logged in successfully.
816 1082
817If the callback returns something, it is sent back as if reply was being 1083If the callback returns something, it is sent back as if reply was being
818called. 1084called.
819 1085
1086=item cf::register_exticmd $name => \&callback($ns,$packet);
1087
1088Register a callback for execution when the client sends an (asynchronous)
1089exticmd packet. Exti commands are processed by the server as soon as they
1090are received, i.e. out of order w.r.t. other commands. The first argument
1091is a client socket. Exti commands can be received anytime, even before
1092log-in.
1093
1094If the callback returns something, it is sent back as if reply was being
1095called.
1096
820=cut 1097=cut
821 1098
822sub register_extcmd { 1099sub register_extcmd {
823 my ($name, $cb) = @_; 1100 my ($name, $cb) = @_;
824 1101
825 $EXTCMD{$name} = $cb; 1102 $EXTCMD{$name} = $cb;
1103}
1104
1105sub register_exticmd {
1106 my ($name, $cb) = @_;
1107
1108 $EXTICMD{$name} = $cb;
826} 1109}
827 1110
828cf::player->attach ( 1111cf::player->attach (
829 on_command => sub { 1112 on_command => sub {
830 my ($pl, $name, $params) = @_; 1113 my ($pl, $name, $params) = @_;
… …
839 cf::override; 1122 cf::override;
840 }, 1123 },
841 on_extcmd => sub { 1124 on_extcmd => sub {
842 my ($pl, $buf) = @_; 1125 my ($pl, $buf) = @_;
843 1126
844 my $msg = eval { from_json $buf }; 1127 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
845 1128
846 if (ref $msg) { 1129 if (ref $msg) {
847 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1130 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
848 if (my %reply = $cb->($pl, $msg)) { 1131 if (my %reply = $cb->($pl, $msg)) {
849 $pl->ext_reply ($msg->{msgid}, %reply); 1132 $pl->ext_reply ($msg->{msgid}, %reply);
… …
855 1138
856 cf::override; 1139 cf::override;
857 }, 1140 },
858); 1141);
859 1142
860sub load_extension {
861 my ($path) = @_;
862
863 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
864 my $base = $1;
865 my $pkg = $1;
866 $pkg =~ s/[^[:word:]]/_/g;
867 $pkg = "ext::$pkg";
868
869 warn "... loading '$path' into '$pkg'\n";
870
871 open my $fh, "<:utf8", $path
872 or die "$path: $!";
873
874 my $source =
875 "package $pkg; use strict; use utf8;\n"
876 . "#line 1 \"$path\"\n{\n"
877 . (do { local $/; <$fh> })
878 . "\n};\n1";
879
880 unless (eval $source) {
881 my $msg = $@ ? "$path: $@\n"
882 : "extension disabled.\n";
883 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
884 warn $@;
885 warn "mandatory extension failed to load, exiting.\n";
886 exit 1;
887 }
888 die $@;
889 }
890
891 push @EXTS, $pkg;
892}
893
894sub load_extensions { 1143sub load_extensions {
1144 cf::sync_job {
1145 my %todo;
1146
895 for my $ext (<$LIBDIR/*.ext>) { 1147 for my $path (<$LIBDIR/*.ext>) {
896 next unless -r $ext; 1148 next unless -r $path;
897 eval { 1149
898 load_extension $ext; 1150 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1151 my $base = $1;
1152 my $pkg = $1;
1153 $pkg =~ s/[^[:word:]]/_/g;
1154 $pkg = "ext::$pkg";
1155
1156 open my $fh, "<:utf8", $path
1157 or die "$path: $!";
1158
1159 my $source = do { local $/; <$fh> };
1160
1161 my %ext = (
1162 path => $path,
1163 base => $base,
1164 pkg => $pkg,
1165 );
1166
1167 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1168 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1169
1170 $ext{source} =
1171 "package $pkg; use strict; use utf8;\n"
1172 . "#line 1 \"$path\"\n{\n"
1173 . $source
1174 . "\n};\n1";
1175
1176 $todo{$base} = \%ext;
1177 }
1178
1179 my %done;
1180 while (%todo) {
1181 my $progress;
1182
1183 while (my ($k, $v) = each %todo) {
1184 for (split /,\s*/, $v->{meta}{depends}) {
1185 goto skip
1186 unless exists $done{$_};
1187 }
1188
1189 warn "... loading '$k' into '$v->{pkg}'\n";
1190
1191 unless (eval $v->{source}) {
1192 my $msg = $@ ? "$v->{path}: $@\n"
1193 : "$v->{base}: extension inactive.\n";
1194
1195 if (exists $v->{meta}{mandatory}) {
1196 warn $msg;
1197 warn "mandatory extension failed to load, exiting.\n";
1198 exit 1;
1199 }
1200
1201 warn $msg;
1202 }
1203
1204 $done{$k} = delete $todo{$k};
1205 push @EXTS, $v->{pkg};
1206 $progress = 1;
899 1 1207 }
900 } or warn "$ext not loaded: $@"; 1208
1209 skip:
1210 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1211 unless $progress;
1212 }
901 } 1213 };
902} 1214}
903 1215
904############################################################################# 1216#############################################################################
905# load/save/clean perl data associated with a map
906 1217
907*cf::mapsupport::on_clean = sub { 1218=back
908 my ($map) = @_;
909
910 my $path = $map->tmpname;
911 defined $path or return;
912
913 unlink "$path.pst";
914};
915
916cf::map->attach (prio => -10000, package => cf::mapsupport::);
917
918#############################################################################
919 1219
920=head2 CORE EXTENSIONS 1220=head2 CORE EXTENSIONS
921 1221
922Functions and methods that extend core crossfire objects. 1222Functions and methods that extend core crossfire objects.
923 1223
… …
936Returns the given player object, loading it if necessary (might block). 1236Returns the given player object, loading it if necessary (might block).
937 1237
938=cut 1238=cut
939 1239
940sub playerdir($) { 1240sub playerdir($) {
941 cf::localdir 1241 "$PLAYERDIR/"
942 . "/"
943 . cf::playerdir
944 . "/"
945 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1242 . (ref $_[0] ? $_[0]->ob->name : $_[0])
946} 1243}
947 1244
948sub path($) { 1245sub path($) {
949 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1246 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
950 1247
951 (playerdir $login) . "/$login.pl" 1248 (playerdir $login) . "/playerdata"
952} 1249}
953 1250
954sub find_active($) { 1251sub find_active($) {
955 $cf::PLAYER{$_[0]} 1252 $cf::PLAYER{$_[0]}
956 and $cf::PLAYER{$_[0]}->active 1253 and $cf::PLAYER{$_[0]}->active
… …
959 1256
960sub exists($) { 1257sub exists($) {
961 my ($login) = @_; 1258 my ($login) = @_;
962 1259
963 $cf::PLAYER{$login} 1260 $cf::PLAYER{$login}
964 or cf::sync_job { !aio_stat $login } 1261 or cf::sync_job { !aio_stat path $login }
965} 1262}
966 1263
967sub find($) { 1264sub find($) {
968 return $cf::PLAYER{$_[0]} || do { 1265 return $cf::PLAYER{$_[0]} || do {
969 my $login = $_[0]; 1266 my $login = $_[0];
970 1267
971 my $guard = cf::lock_acquire "user_find:$login"; 1268 my $guard = cf::lock_acquire "user_find:$login";
972 1269
973 $cf::PLAYER{$_[0]} || do { 1270 $cf::PLAYER{$_[0]} || do {
1271 # rename old playerfiles to new ones
1272 #TODO: remove when no longer required
1273 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1274 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1275 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1276 aio_unlink +(playerdir $login) . "/$login.pl";
1277
974 my $pl = load_pl path $login 1278 my $pl = load_pl path $login
975 or return; 1279 or return;
976 $cf::PLAYER{$login} = $pl 1280 $cf::PLAYER{$login} = $pl
977 } 1281 }
978 } 1282 }
… …
1015 1319
1016=cut 1320=cut
1017 1321
1018sub quit_character { 1322sub quit_character {
1019 my ($pl) = @_; 1323 my ($pl) = @_;
1324
1325 my $name = $pl->ob->name;
1020 1326
1021 $pl->{deny_save} = 1; 1327 $pl->{deny_save} = 1;
1022 $pl->password ("*"); # this should lock out the player until we nuked the dir 1328 $pl->password ("*"); # this should lock out the player until we nuked the dir
1023 1329
1024 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1330 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
… …
1029 my $path = playerdir $pl; 1335 my $path = playerdir $pl;
1030 my $temp = "$path~$cf::RUNTIME~deleting~"; 1336 my $temp = "$path~$cf::RUNTIME~deleting~";
1031 aio_rename $path, $temp; 1337 aio_rename $path, $temp;
1032 delete $cf::PLAYER{$pl->ob->name}; 1338 delete $cf::PLAYER{$pl->ob->name};
1033 $pl->destroy; 1339 $pl->destroy;
1340
1341 my $prefix = qr<^~\Q$name\E/>;
1342
1343 # nuke player maps
1344 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1345
1034 IO::AIO::aio_rmtree $temp; 1346 IO::AIO::aio_rmtree $temp;
1347}
1348
1349=item $pl->kick
1350
1351Kicks a player out of the game. This destroys the connection.
1352
1353=cut
1354
1355sub kick {
1356 my ($pl, $kicker) = @_;
1357
1358 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1359 $pl->killer ("kicked");
1360 $pl->ns->destroy;
1035} 1361}
1036 1362
1037=item cf::player::list_logins 1363=item cf::player::list_logins
1038 1364
1039Returns am arrayref of all valid playernames in the system, can take a 1365Returns am arrayref of all valid playernames in the system, can take a
1040while and may block, so not sync_job-capable, ever. 1366while and may block, so not sync_job-capable, ever.
1041 1367
1042=cut 1368=cut
1043 1369
1044sub list_logins { 1370sub list_logins {
1045 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1371 my $dirs = aio_readdir $PLAYERDIR
1046 or return []; 1372 or return [];
1047 1373
1048 my @logins; 1374 my @logins;
1049 1375
1050 for my $login (@$dirs) { 1376 for my $login (@$dirs) {
… …
1067=cut 1393=cut
1068 1394
1069sub maps($) { 1395sub maps($) {
1070 my ($pl) = @_; 1396 my ($pl) = @_;
1071 1397
1398 $pl = ref $pl ? $pl->ob->name : $pl;
1399
1072 my $files = aio_readdir playerdir $pl 1400 my $files = aio_readdir playerdir $pl
1073 or return; 1401 or return;
1074 1402
1075 my @paths; 1403 my @paths;
1076 1404
1077 for (@$files) { 1405 for (@$files) {
1078 utf8::decode $_; 1406 utf8::decode $_;
1079 next if /\.(?:pl|pst)$/; 1407 next if /\.(?:pl|pst)$/;
1080 next unless /^$PATH_SEP/o; 1408 next unless /^$PATH_SEP/o;
1081 1409
1082 push @paths, "~" . $pl->ob->name . "/" . $_; 1410 push @paths, cf::map::normalise "~$pl/$_";
1083 } 1411 }
1084 1412
1085 \@paths 1413 \@paths
1086} 1414}
1087 1415
1416=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1417
1418Expand crossfire pod fragments into protocol xml.
1419
1420=cut
1421
1422sub expand_cfpod {
1423 ((my $self), (local $_)) = @_;
1424
1425 # escape & and <
1426 s/&/&amp;/g;
1427 s/(?<![BIUGH])</&lt;/g;
1428
1429 # this is buggy, it needs to properly take care of nested <'s
1430
1431 1 while
1432 # replace B<>, I<>, U<> etc.
1433 s/B<([^\>]*)>/<b>$1<\/b>/
1434 || s/I<([^\>]*)>/<i>$1<\/i>/
1435 || s/U<([^\>]*)>/<u>$1<\/u>/
1436 # replace G<male|female> tags
1437 || s{G<([^>|]*)\|([^>]*)>}{
1438 $self->gender ? $2 : $1
1439 }ge
1440 # replace H<hint text>
1441 || s{H<([^\>]*)>}
1442 {
1443 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1444 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1445 "")
1446 [$self->{hintmode}]
1447 }ge;
1448
1449 # create single paragraphs (very hackish)
1450 s/(?<=\S)\n(?=\w)/ /g;
1451
1452 # compress some whitespace
1453 s/\s+\n/\n/g; # ws line-ends
1454 s/\n\n+/\n/g; # double lines
1455 s/^\n+//; # beginning lines
1456 s/\n+$//; # ending lines
1457
1458 $_
1459}
1460
1461sub hintmode {
1462 $_[0]{hintmode} = $_[1] if @_ > 1;
1463 $_[0]{hintmode}
1464}
1465
1088=item $player->ext_reply ($msgid, $msgtype, %msg) 1466=item $player->ext_reply ($msgid, %msg)
1089 1467
1090Sends an ext reply to the player. 1468Sends an ext reply to the player.
1091 1469
1092=cut 1470=cut
1093 1471
1094sub ext_reply($$$%) { 1472sub ext_reply($$%) {
1095 my ($self, $id, %msg) = @_; 1473 my ($self, $id, %msg) = @_;
1096 1474
1097 $msg{msgid} = $id; 1475 $msg{msgid} = $id;
1098 1476 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1099 $self->send ("ext " . cf::to_json \%msg);
1100} 1477}
1101 1478
1102package cf; 1479=item $player->ext_event ($type, %msg)
1480
1481Sends an ext event to the client.
1482
1483=cut
1484
1485sub ext_event($$%) {
1486 my ($self, $type, %msg) = @_;
1487
1488 $self->ns->ext_event ($type, %msg);
1489}
1490
1491=head3 cf::region
1492
1493=over 4
1494
1495=cut
1496
1497package cf::region;
1498
1499=item cf::region::find_by_path $path
1500
1501Tries to decuce the likely region for a map knowing only its path.
1502
1503=cut
1504
1505sub find_by_path($) {
1506 my ($path) = @_;
1507
1508 my ($match, $specificity);
1509
1510 for my $region (list) {
1511 if ($region->{match} && $path =~ $region->{match}) {
1512 ($match, $specificity) = ($region, $region->specificity)
1513 if $region->specificity > $specificity;
1514 }
1515 }
1516
1517 $match
1518}
1103 1519
1104=back 1520=back
1105
1106 1521
1107=head3 cf::map 1522=head3 cf::map
1108 1523
1109=over 4 1524=over 4
1110 1525
… …
1114 1529
1115use Fcntl; 1530use Fcntl;
1116use Coro::AIO; 1531use Coro::AIO;
1117 1532
1118use overload 1533use overload
1119 '""' => \&as_string; 1534 '""' => \&as_string,
1535 fallback => 1;
1120 1536
1121our $MAX_RESET = 3600; 1537our $MAX_RESET = 3600;
1122our $DEFAULT_RESET = 3000; 1538our $DEFAULT_RESET = 3000;
1123 1539
1124sub generate_random_map { 1540sub generate_random_map {
1125 my ($self, $rmp) = @_; 1541 my ($self, $rmp) = @_;
1126
1127 # mit "rum" bekleckern, nicht 1542 # mit "rum" bekleckern, nicht
1128 $self->_create_random_map ( 1543 $self->_create_random_map (
1129 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1544 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1130 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1545 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1131 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1546 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1138 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1553 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1139 (cf::region::find $rmp->{region}), $rmp->{custom} 1554 (cf::region::find $rmp->{region}), $rmp->{custom}
1140 ) 1555 )
1141} 1556}
1142 1557
1558=item cf::map->register ($regex, $prio)
1559
1560Register a handler for the map path matching the given regex at the
1561givne priority (higher is better, built-in handlers have priority 0, the
1562default).
1563
1564=cut
1565
1143sub register { 1566sub register {
1144 my (undef, $regex) = @_; 1567 my (undef, $regex, $prio) = @_;
1145 my $pkg = caller; 1568 my $pkg = caller;
1146 1569
1147 no strict; 1570 no strict;
1148 push @{"$pkg\::ISA"}, __PACKAGE__; 1571 push @{"$pkg\::ISA"}, __PACKAGE__;
1149 1572
1150 $EXT_MAP{$pkg} = qr<$regex>; 1573 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1151} 1574}
1152 1575
1153# also paths starting with '/' 1576# also paths starting with '/'
1154$EXT_MAP{"cf::map"} = qr{^(?=/)}; 1577$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1578
1579sub thawer_merge {
1580 my ($self, $merge) = @_;
1581
1582 # we have to keep some variables in memory intact
1583 local $self->{path};
1584 local $self->{load_path};
1585
1586 $self->SUPER::thawer_merge ($merge);
1587}
1155 1588
1156sub normalise { 1589sub normalise {
1157 my ($path, $base) = @_; 1590 my ($path, $base) = @_;
1591
1592 $path = "$path"; # make sure its a string
1593
1594 $path =~ s/\.map$//;
1158 1595
1159 # map plan: 1596 # map plan:
1160 # 1597 #
1161 # /! non-realised random map exit (special hack!) 1598 # /! non-realised random map exit (special hack!)
1162 # {... are special paths that are not being touched 1599 # {... are special paths that are not being touched
… …
1190 1627
1191 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object 1628 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1192 1629
1193 $path = normalise $path, $base; 1630 $path = normalise $path, $base;
1194 1631
1195 for my $pkg (keys %EXT_MAP) { 1632 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1196 if ($path =~ $EXT_MAP{$pkg}) { 1633 if ($path =~ $EXT_MAP{$pkg}[1]) {
1197 my $self = bless cf::map::new, $pkg; 1634 my $self = bless cf::map::new, $pkg;
1198 $self->{path} = $path; $self->path ($path); 1635 $self->{path} = $path; $self->path ($path);
1199 $self->init; # pass $1 etc. 1636 $self->init; # pass $1 etc.
1200 return $self; 1637 return $self;
1201 } 1638 }
1202 } 1639 }
1203 1640
1204 Carp::carp "unable to resolve path '$path'."; 1641 Carp::cluck "unable to resolve path '$path' (base '$base').";
1205 () 1642 ()
1206} 1643}
1207 1644
1208sub init { 1645sub init {
1209 my ($self) = @_; 1646 my ($self) = @_;
… …
1220# the displayed name, this is a one way mapping 1657# the displayed name, this is a one way mapping
1221sub visible_name { 1658sub visible_name {
1222 &as_string 1659 &as_string
1223} 1660}
1224 1661
1225# escape the /'s in the path
1226sub _escaped_path {
1227 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1228
1229 $path
1230}
1231
1232# the original (read-only) location 1662# the original (read-only) location
1233sub load_path { 1663sub load_path {
1234 my ($self) = @_; 1664 my ($self) = @_;
1235 1665
1236 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path} 1666 "$MAPDIR/$self->{path}.map"
1237} 1667}
1238 1668
1239# the temporary/swap location 1669# the temporary/swap location
1240sub save_path { 1670sub save_path {
1241 my ($self) = @_; 1671 my ($self) = @_;
1242 1672
1243 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $self->_escaped_path 1673 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1674 "$TMPDIR/$path.map"
1244} 1675}
1245 1676
1246# the unique path, undef == no special unique path 1677# the unique path, undef == no special unique path
1247sub uniq_path { 1678sub uniq_path {
1248 my ($self) = @_; 1679 my ($self) = @_;
1249 1680
1250 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path 1681 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1682 "$UNIQUEDIR/$path"
1251} 1683}
1252 1684
1253# and all this just because we cannot iterate over 1685# and all this just because we cannot iterate over
1254# all maps in C++... 1686# all maps in C++...
1255sub change_all_map_light { 1687sub change_all_map_light {
… …
1257 1689
1258 $_->change_map_light ($change) 1690 $_->change_map_light ($change)
1259 for grep $_->outdoor, values %cf::MAP; 1691 for grep $_->outdoor, values %cf::MAP;
1260} 1692}
1261 1693
1694sub decay_objects {
1695 my ($self) = @_;
1696
1697 return if $self->{deny_reset};
1698
1699 $self->do_decay_objects;
1700}
1701
1262sub unlink_save { 1702sub unlink_save {
1263 my ($self) = @_; 1703 my ($self) = @_;
1264 1704
1265 utf8::encode (my $save = $self->save_path); 1705 utf8::encode (my $save = $self->save_path);
1266 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink $save; 1706 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1267 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink "$save.pst"; 1707 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1268} 1708}
1269 1709
1270sub load_header_from($) { 1710sub load_header_from($) {
1271 my ($self, $path) = @_; 1711 my ($self, $path) = @_;
1272 1712
1273 utf8::encode $path; 1713 utf8::encode $path;
1274 aio_open $path, O_RDONLY, 0 1714 #aio_open $path, O_RDONLY, 0
1275 or return; 1715 # or return;
1276 1716
1277 $self->_load_header ($path) 1717 $self->_load_header ($path)
1278 or return; 1718 or return;
1279 1719
1280 $self->{load_path} = $path; 1720 $self->{load_path} = $path;
1281 1721
1282 1 1722 1
1283} 1723}
1284 1724
1285sub load_orig { 1725sub load_header_orig {
1286 my ($self) = @_; 1726 my ($self) = @_;
1287 1727
1288 $self->load_header_from ($self->load_path) 1728 $self->load_header_from ($self->load_path)
1289} 1729}
1290 1730
1291sub load_temp { 1731sub load_header_temp {
1292 my ($self) = @_; 1732 my ($self) = @_;
1293 1733
1294 $self->load_header_from ($self->save_path) 1734 $self->load_header_from ($self->save_path)
1735}
1736
1737sub prepare_temp {
1738 my ($self) = @_;
1739
1740 $self->last_access ((delete $self->{last_access})
1741 || $cf::RUNTIME); #d#
1742 # safety
1743 $self->{instantiate_time} = $cf::RUNTIME
1744 if $self->{instantiate_time} > $cf::RUNTIME;
1745}
1746
1747sub prepare_orig {
1748 my ($self) = @_;
1749
1750 $self->{load_original} = 1;
1751 $self->{instantiate_time} = $cf::RUNTIME;
1752 $self->last_access ($cf::RUNTIME);
1753 $self->instantiate;
1295} 1754}
1296 1755
1297sub load_header { 1756sub load_header {
1298 my ($self) = @_; 1757 my ($self) = @_;
1299 1758
1300 if ($self->load_temp) { 1759 if ($self->load_header_temp) {
1301 $self->last_access ((delete $self->{last_access}) 1760 $self->prepare_temp;
1302 || $cf::RUNTIME); #d#
1303 # safety
1304 $self->{instantiate_time} = $cf::RUNTIME
1305 if $self->{instantiate_time} > $cf::RUNTIME;
1306 } else { 1761 } else {
1307 $self->load_orig 1762 $self->load_header_orig
1308 or return; 1763 or return;
1309 1764 $self->prepare_orig;
1310 $self->{load_original} = 1;
1311 $self->{instantiate_time} = $cf::RUNTIME;
1312 $self->last_access ($cf::RUNTIME);
1313 $self->instantiate;
1314 } 1765 }
1766
1767 $self->{deny_reset} = 1
1768 if $self->no_reset;
1769
1770 $self->default_region (cf::region::find_by_path $self->{path})
1771 unless $self->default_region;
1315 1772
1316 1 1773 1
1317} 1774}
1318 1775
1319sub find; 1776sub find;
… …
1332 $map->{last_save} = $cf::RUNTIME; 1789 $map->{last_save} = $cf::RUNTIME;
1333 1790
1334 $map->load_header 1791 $map->load_header
1335 or return; 1792 or return;
1336 1793
1337 if ($map->should_reset) { 1794 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1795 # doing this can freeze the server in a sync job, obviously
1796 #$cf::WAIT_FOR_TICK->wait;
1338 $map->reset; 1797 $map->reset;
1339 undef $guard; 1798 undef $guard;
1340 $map = find $path 1799 return find $path;
1341 or return;
1342 } 1800 }
1343 1801
1344 $cf::MAP{$path} = $map 1802 $cf::MAP{$path} = $map
1345 } 1803 }
1346} 1804}
1805
1806sub pre_load { }
1807sub post_load { }
1347 1808
1348sub load { 1809sub load {
1349 my ($self) = @_; 1810 my ($self) = @_;
1350 1811
1812 local $self->{deny_reset} = 1; # loading can take a long time
1813
1351 my $path = $self->{path}; 1814 my $path = $self->{path};
1815
1816 {
1352 my $guard = cf::lock_acquire "map_load:$path"; 1817 my $guard = cf::lock_acquire "map_load:$path";
1353 1818
1354 return if $self->in_memory != cf::MAP_SWAPPED; 1819 return if $self->in_memory != cf::MAP_SWAPPED;
1355 1820
1356 $self->in_memory (cf::MAP_LOADING); 1821 $self->in_memory (cf::MAP_LOADING);
1357 1822
1358 $self->alloc; 1823 $self->alloc;
1359 $self->_load_objects ($self->{load_path}, 1)
1360 or return;
1361 1824
1362 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1825 $self->pre_load;
1363 if delete $self->{load_original};
1364
1365 if (my $uniq = $self->uniq_path) {
1366 utf8::encode $uniq;
1367 if (aio_open $uniq, O_RDONLY, 0) {
1368 $self->clear_unique_items;
1369 $self->_load_objects ($uniq, 0);
1370 }
1371 }
1372
1373 Coro::cede;
1374
1375 # now do the right thing for maps
1376 $self->link_multipart_objects;
1377
1378 unless ($self->{deny_activate}) {
1379 $self->decay_objects;
1380 $self->fix_auto_apply;
1381 $self->update_buttons;
1382 Coro::cede; 1826 Coro::cede;
1383 $self->set_darkness_map; 1827
1828 $self->_load_objects ($self->{load_path}, 1)
1829 or return;
1830
1831 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1832 if delete $self->{load_original};
1833
1834 if (my $uniq = $self->uniq_path) {
1835 utf8::encode $uniq;
1836 if (aio_open $uniq, O_RDONLY, 0) {
1837 $self->clear_unique_items;
1838 $self->_load_objects ($uniq, 0);
1839 }
1840 }
1841
1842 Coro::cede;
1843 # now do the right thing for maps
1844 $self->link_multipart_objects;
1384 $self->difficulty ($self->estimate_difficulty) 1845 $self->difficulty ($self->estimate_difficulty)
1385 unless $self->difficulty; 1846 unless $self->difficulty;
1386 Coro::cede; 1847 Coro::cede;
1848
1849 unless ($self->{deny_activate}) {
1850 $self->decay_objects;
1851 $self->fix_auto_apply;
1852 $self->update_buttons;
1853 Coro::cede;
1854 $self->set_darkness_map;
1855 Coro::cede;
1387 $self->activate; 1856 $self->activate;
1388 } 1857 }
1389 1858
1390 $self->in_memory (cf::MAP_IN_MEMORY); 1859 $self->in_memory (cf::MAP_IN_MEMORY);
1860 }
1861
1862 $self->post_load;
1391} 1863}
1392 1864
1393sub customise_for { 1865sub customise_for {
1394 my ($self, $ob) = @_; 1866 my ($self, $ob) = @_;
1395 1867
1396 return find "~" . $ob->name . "/" . $self->{path} 1868 return find "~" . $ob->name . "/" . $self->{path}
1397 if $self->per_player; 1869 if $self->per_player;
1870
1871# return find "?party/" . $ob->name . "/" . $self->{path}
1872# if $self->per_party;
1398 1873
1399 $self 1874 $self
1400} 1875}
1401 1876
1402# find and load all maps in the 3x3 area around a map 1877# find and load all maps in the 3x3 area around a map
… …
1434 1909
1435 cf::sync_job { $map->load }; 1910 cf::sync_job { $map->load };
1436} 1911}
1437 1912
1438our %MAP_PREFETCH; 1913our %MAP_PREFETCH;
1439our $MAP_PREFETCHER = Coro::async { 1914our $MAP_PREFETCHER = undef;
1440 while () {
1441 for my $path (keys %MAP_PREFETCH) {
1442 my $map = find $path
1443 or next;
1444 $map->load;
1445
1446 delete $MAP_PREFETCH{$path};
1447 }
1448 Coro::schedule;
1449 }
1450};
1451 1915
1452sub find_async { 1916sub find_async {
1453 my ($path, $origin) = @_; 1917 my ($path, $origin) = @_;
1454 1918
1455 $path = normalise $path, $origin && $origin->{path}; 1919 $path = normalise $path, $origin && $origin->{path};
1456 1920
1457 if (my $map = $cf::MAP{$path}) { 1921 if (my $map = $cf::MAP{$path}) {
1458 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 1922 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1459 } 1923 }
1460 1924
1461 $MAP_PREFETCH{$path} = 0; 1925 undef $MAP_PREFETCH{$path};
1926 $MAP_PREFETCHER ||= cf::async {
1927 while (%MAP_PREFETCH) {
1928 for my $path (keys %MAP_PREFETCH) {
1929 if (my $map = find $path) {
1930 $map->load;
1931 }
1932
1933 delete $MAP_PREFETCH{$path};
1934 }
1935 }
1936 undef $MAP_PREFETCHER;
1937 };
1462 $MAP_PREFETCHER->ready; 1938 $MAP_PREFETCHER->prio (6);
1463 1939
1464 () 1940 ()
1465} 1941}
1466 1942
1467sub save { 1943sub save {
… …
1512 1988
1513sub reset_at { 1989sub reset_at {
1514 my ($self) = @_; 1990 my ($self) = @_;
1515 1991
1516 # TODO: safety, remove and allow resettable per-player maps 1992 # TODO: safety, remove and allow resettable per-player maps
1517 return 1e99 if $self->isa ("ext::map_per_player");
1518 return 1e99 if $self->{deny_reset}; 1993 return 1e99 if $self->{deny_reset};
1519 1994
1520 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1995 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1521 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1996 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1522 1997
… …
1527 my ($self) = @_; 2002 my ($self) = @_;
1528 2003
1529 $self->reset_at <= $cf::RUNTIME 2004 $self->reset_at <= $cf::RUNTIME
1530} 2005}
1531 2006
1532sub rename {
1533 my ($self, $new_path) = @_;
1534
1535 normalise $new_path;
1536
1537 $self->unlink_save;
1538
1539 delete $cf::MAP{$self->path};
1540 $self->{path} = $new_path; $self->path ($self->{path});
1541 $cf::MAP{$self->path} = $self;
1542
1543 $self->save;
1544}
1545
1546sub reset { 2007sub reset {
1547 my ($self) = @_; 2008 my ($self) = @_;
1548 2009
1549 my $lock = cf::lock_acquire "map_data:" . $self->path; 2010 my $lock = cf::lock_acquire "map_data:$self->{path}";
1550 2011
1551 return if $self->players; 2012 return if $self->players;
1552 return if $self->isa ("ext::map_per_player");#d#
1553 2013
1554 warn "resetting map ", $self->path;#d# 2014 warn "resetting map ", $self->path;
2015
2016 $self->in_memory (cf::MAP_SWAPPED);
2017
2018 # need to save uniques path
2019 unless ($self->{deny_save}) {
2020 my $uniq = $self->uniq_path; utf8::encode $uniq;
2021
2022 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2023 if $uniq;
2024 }
1555 2025
1556 delete $cf::MAP{$self->path}; 2026 delete $cf::MAP{$self->path};
2027
2028 $self->clear;
1557 2029
1558 $_->clear_links_to ($self) for values %cf::MAP; 2030 $_->clear_links_to ($self) for values %cf::MAP;
1559 2031
1560 $self->unlink_save; 2032 $self->unlink_save;
1561 $self->destroy; 2033 $self->destroy;
… …
1564my $nuke_counter = "aaaa"; 2036my $nuke_counter = "aaaa";
1565 2037
1566sub nuke { 2038sub nuke {
1567 my ($self) = @_; 2039 my ($self) = @_;
1568 2040
2041 delete $cf::MAP{$self->path};
2042
2043 $self->unlink_save;
2044
2045 bless $self, "cf::map";
2046 delete $self->{deny_reset};
1569 $self->{deny_save} = 1; 2047 $self->{deny_save} = 1;
1570 $self->reset_timeout (1); 2048 $self->reset_timeout (1);
1571 $self->rename ("{nuke}/" . ($nuke_counter++)); 2049 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2050
2051 $cf::MAP{$self->path} = $self;
2052
1572 $self->reset; # polite request, might not happen 2053 $self->reset; # polite request, might not happen
2054}
2055
2056=item $maps = cf::map::tmp_maps
2057
2058Returns an arrayref with all map paths of currently instantiated and saved
2059maps. May block.
2060
2061=cut
2062
2063sub tmp_maps() {
2064 [
2065 map {
2066 utf8::decode $_;
2067 /\.map$/
2068 ? normalise $_
2069 : ()
2070 } @{ aio_readdir $TMPDIR or [] }
2071 ]
2072}
2073
2074=item $maps = cf::map::random_maps
2075
2076Returns an arrayref with all map paths of currently instantiated and saved
2077random maps. May block.
2078
2079=cut
2080
2081sub random_maps() {
2082 [
2083 map {
2084 utf8::decode $_;
2085 /\.map$/
2086 ? normalise "?random/$_"
2087 : ()
2088 } @{ aio_readdir $RANDOMDIR or [] }
2089 ]
1573} 2090}
1574 2091
1575=item cf::map::unique_maps 2092=item cf::map::unique_maps
1576 2093
1577Returns an arrayref of paths of all shared maps that have 2094Returns an arrayref of paths of all shared maps that have
1578instantiated unique items. May block. 2095instantiated unique items. May block.
1579 2096
1580=cut 2097=cut
1581 2098
1582sub unique_maps() { 2099sub unique_maps() {
1583 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2100 [
1584 or return; 2101 map {
1585
1586 my @paths;
1587
1588 for (@$files) {
1589 utf8::decode $_; 2102 utf8::decode $_;
1590 next if /\.pst$/; 2103 /\.map$/
1591 next unless /^$PATH_SEP/o; 2104 ? normalise $_
1592 2105 : ()
1593 push @paths, $_; 2106 } @{ aio_readdir $UNIQUEDIR or [] }
1594 } 2107 ]
1595
1596 \@paths
1597} 2108}
1598 2109
1599package cf; 2110package cf;
1600 2111
1601=back 2112=back
… …
1647 2158
1648 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2159 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1649 2160
1650 if ($self->{record_replies}) { 2161 if ($self->{record_replies}) {
1651 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2162 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2163
1652 } else { 2164 } else {
2165 my $pl = $self->contr;
2166
2167 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2168 my $diag = $pl->{npc_dialog};
2169 $diag->{pl}->ext_reply (
2170 $diag->{id},
2171 msgtype => "reply",
2172 msg => $diag->{pl}->expand_cfpod ($msg),
2173 add_topics => []
2174 );
2175
2176 } else {
1653 $msg = $npc->name . " says: $msg" if $npc; 2177 $msg = $npc->name . " says: $msg" if $npc;
1654 $self->message ($msg, $flags); 2178 $self->message ($msg, $flags);
2179 }
1655 } 2180 }
1656} 2181}
1657 2182
1658=item $player_object->may ("access") 2183=item $player_object->may ("access")
1659 2184
… …
1692=cut 2217=cut
1693 2218
1694sub link_map { 2219sub link_map {
1695 unless ($LINK_MAP) { 2220 unless ($LINK_MAP) {
1696 $LINK_MAP = cf::map::find "{link}" 2221 $LINK_MAP = cf::map::find "{link}"
1697 or do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 }; 2222 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1698 $LINK_MAP->load; 2223 $LINK_MAP->load;
1699 } 2224 }
1700 2225
1701 $LINK_MAP 2226 $LINK_MAP
1702} 2227}
… …
1707 $self->deactivate_recursive; 2232 $self->deactivate_recursive;
1708 2233
1709 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2234 return if UNIVERSAL::isa $self->map, "ext::map_link";
1710 2235
1711 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2236 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1712 if $self->map; 2237 if $self->map && $self->map->{path} ne "{link}";
1713 2238
1714 $self->enter_map ($LINK_MAP || link_map, 20, 20); 2239 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1715} 2240}
1716 2241
1717sub cf::object::player::leave_link { 2242sub cf::object::player::leave_link {
1718 my ($self, $map, $x, $y) = @_; 2243 my ($self, $map, $x, $y) = @_;
2244
2245 return unless $self->contr->active;
1719 2246
1720 my $link_pos = delete $self->{_link_pos}; 2247 my $link_pos = delete $self->{_link_pos};
1721 2248
1722 unless ($map) { 2249 unless ($map) {
1723 # restore original map position 2250 # restore original map position
… …
1741 $map->load; 2268 $map->load;
1742 $map->load_diag; 2269 $map->load_diag;
1743 2270
1744 return unless $self->contr->active; 2271 return unless $self->contr->active;
1745 $self->activate_recursive; 2272 $self->activate_recursive;
2273
2274 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1746 $self->enter_map ($map, $x, $y); 2275 $self->enter_map ($map, $x, $y);
1747} 2276}
1748 2277
1749cf::player->attach ( 2278=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1750 on_logout => sub {
1751 my ($pl) = @_;
1752 2279
1753 # abort map switching before logout 2280Moves the player to the given map-path and coordinates by first freezing
1754 if ($pl->ob->{_link_pos}) { 2281her, loading and preparing them map, calling the provided $check callback
1755 cf::sync_job { 2282that has to return the map if sucecssful, and then unfreezes the player on
1756 $pl->ob->leave_link 2283the new (success) or old (failed) map position. In either case, $done will
1757 }; 2284be called at the end of this process.
1758 }
1759 },
1760 on_login => sub {
1761 my ($pl) = @_;
1762 2285
1763 # try to abort aborted map switching on player login :)
1764 # should happen only on crashes
1765 if ($pl->ob->{_link_pos}) {
1766 $pl->ob->enter_link;
1767 (async {
1768 # we need this sleep as the login has a concurrent enter_exit running
1769 # and this sleep increases chances of the player not ending up in scorn
1770 $pl->ob->reply (undef,
1771 "There was an internal problem at your last logout, "
1772 . "the server will try to bring you to your intended destination in a second.",
1773 cf::NDI_RED);
1774 Coro::Timer::sleep 1;
1775 $pl->ob->leave_link;
1776 })->prio (2);
1777 }
1778 },
1779);
1780
1781=item $player_object->goto ($path, $x, $y)
1782
1783=cut 2286=cut
2287
2288our $GOTOGEN;
1784 2289
1785sub cf::object::player::goto { 2290sub cf::object::player::goto {
1786 my ($self, $path, $x, $y) = @_; 2291 my ($self, $path, $x, $y, $check, $done) = @_;
2292
2293 # do generation counting so two concurrent goto's will be executed in-order
2294 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1787 2295
1788 $self->enter_link; 2296 $self->enter_link;
1789 2297
1790 (async { 2298 (async {
2299 my $map = eval {
1791 my $map = cf::map::find $path; 2300 my $map = cf::map::find $path;
2301
2302 if ($map) {
1792 $map = $map->customise_for ($self) if $map; 2303 $map = $map->customise_for ($self);
1793 2304 $map = $check->($map) if $check && $map;
1794# warn "entering ", $map->path, " at ($x, $y)\n" 2305 } else {
1795# if $map;
1796
1797 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2306 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2307 }
1798 2308
2309 $map
2310 };
2311
2312 if ($@) {
2313 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2314 LOG llevError | logBacktrace, Carp::longmess $@;
2315 }
2316
2317 if ($gen == $self->{_goto_generation}) {
2318 delete $self->{_goto_generation};
1799 $self->leave_link ($map, $x, $y); 2319 $self->leave_link ($map, $x, $y);
2320 }
2321
2322 $done->() if $done;
1800 })->prio (1); 2323 })->prio (1);
1801} 2324}
1802 2325
1803=item $player_object->enter_exit ($exit_object) 2326=item $player_object->enter_exit ($exit_object)
1804 2327
… …
1806 2329
1807sub parse_random_map_params { 2330sub parse_random_map_params {
1808 my ($spec) = @_; 2331 my ($spec) = @_;
1809 2332
1810 my $rmp = { # defaults 2333 my $rmp = { # defaults
1811 xsize => 10, 2334 xsize => (cf::rndm 15, 40),
1812 ysize => 10, 2335 ysize => (cf::rndm 15, 40),
2336 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2337 #layout => string,
1813 }; 2338 };
1814 2339
1815 for (split /\n/, $spec) { 2340 for (split /\n/, $spec) {
1816 my ($k, $v) = split /\s+/, $_, 2; 2341 my ($k, $v) = split /\s+/, $_, 2;
1817 2342
… …
1821 $rmp 2346 $rmp
1822} 2347}
1823 2348
1824sub prepare_random_map { 2349sub prepare_random_map {
1825 my ($exit) = @_; 2350 my ($exit) = @_;
2351
2352 my $guard = cf::lock_acquire "exit_prepare:$exit";
1826 2353
1827 # all this does is basically replace the /! path by 2354 # all this does is basically replace the /! path by
1828 # a new random map path (?random/...) with a seed 2355 # a new random map path (?random/...) with a seed
1829 # that depends on the exit object 2356 # that depends on the exit object
1830 2357
1831 my $rmp = parse_random_map_params $exit->msg; 2358 my $rmp = parse_random_map_params $exit->msg;
1832 2359
1833 if ($exit->map) { 2360 if ($exit->map) {
1834 $rmp->{region} = $exit->map->region_name; 2361 $rmp->{region} = $exit->region->name;
1835 $rmp->{origin_map} = $exit->map->path; 2362 $rmp->{origin_map} = $exit->map->path;
1836 $rmp->{origin_x} = $exit->x; 2363 $rmp->{origin_x} = $exit->x;
1837 $rmp->{origin_y} = $exit->y; 2364 $rmp->{origin_y} = $exit->y;
1838 } 2365 }
1839 2366
1840 $rmp->{random_seed} ||= $exit->random_seed; 2367 $rmp->{random_seed} ||= $exit->random_seed;
1841 2368
1842 my $data = cf::to_json $rmp; 2369 my $data = cf::to_json $rmp;
1843 my $md5 = Digest::MD5::md5_hex $data; 2370 my $md5 = Digest::MD5::md5_hex $data;
2371 my $meta = "$RANDOMDIR/$md5.meta";
1844 2372
1845 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) { 2373 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1846 aio_write $fh, 0, (length $data), $data, 0; 2374 aio_write $fh, 0, (length $data), $data, 0;
2375 undef $fh;
2376 aio_rename "$meta~", $meta;
1847 2377
1848 $exit->slaying ("?random/$md5"); 2378 $exit->slaying ("?random/$md5");
1849 $exit->msg (undef); 2379 $exit->msg (undef);
1850 } 2380 }
1851} 2381}
… …
1853sub cf::object::player::enter_exit { 2383sub cf::object::player::enter_exit {
1854 my ($self, $exit) = @_; 2384 my ($self, $exit) = @_;
1855 2385
1856 return unless $self->type == cf::PLAYER; 2386 return unless $self->type == cf::PLAYER;
1857 2387
2388 if ($exit->slaying eq "/!") {
2389 #TODO: this should de-fi-ni-te-ly not be a sync-job
2390 # the problem is that $exit might not survive long enough
2391 # so it needs to be done right now, right here
2392 cf::sync_job { prepare_random_map $exit };
2393 }
2394
2395 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2396 my $hp = $exit->stats->hp;
2397 my $sp = $exit->stats->sp;
2398
1858 $self->enter_link; 2399 $self->enter_link;
2400
2401 # if exit is damned, update players death & WoR home-position
2402 $self->contr->savebed ($slaying, $hp, $sp)
2403 if $exit->flag (FLAG_DAMNED);
1859 2404
1860 (async { 2405 (async {
1861 $self->deactivate_recursive; # just to be sure 2406 $self->deactivate_recursive; # just to be sure
1862 unless (eval { 2407 unless (eval {
1863 prepare_random_map $exit 2408 $self->goto ($slaying, $hp, $sp);
1864 if $exit->slaying eq "/!";
1865
1866 my $path = new_from_path cf::map $exit->slaying, $exit->map && $exit->map->path;
1867 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1868 2409
1869 1; 2410 1;
1870 }) { 2411 }) {
1871 $self->message ("Something went wrong deep within the crossfire server. " 2412 $self->message ("Something went wrong deep within the crossfire server. "
1872 . "I'll try to bring you back to the map you were before. " 2413 . "I'll try to bring you back to the map you were before. "
1873 . "Please report this to the dungeon master!", 2414 . "Please report this to the dungeon master!",
1874 cf::NDI_UNIQUE | cf::NDI_RED); 2415 cf::NDI_UNIQUE | cf::NDI_RED);
1875 2416
1876 warn "ERROR in enter_exit: $@"; 2417 warn "ERROR in enter_exit: $@";
1877 $self->leave_link; 2418 $self->leave_link;
1878 } 2419 }
1879 })->prio (1); 2420 })->prio (1);
… …
1892 2433
1893sub cf::client::send_drawinfo { 2434sub cf::client::send_drawinfo {
1894 my ($self, $text, $flags) = @_; 2435 my ($self, $text, $flags) = @_;
1895 2436
1896 utf8::encode $text; 2437 utf8::encode $text;
1897 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2438 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1898} 2439}
1899 2440
2441=item $client->send_msg ($channel, $msg, $color, [extra...])
2442
2443Send a drawinfo or msg packet to the client, formatting the msg for the
2444client if neccessary. C<$type> should be a string identifying the type of
2445the message, with C<log> being the default. If C<$color> is negative, suppress
2446the message unless the client supports the msg packet.
2447
2448=cut
2449
2450sub cf::client::send_msg {
2451 my ($self, $channel, $msg, $color, @extra) = @_;
2452
2453 $msg = $self->pl->expand_cfpod ($msg);
2454
2455 $color &= ~cf::NDI_UNIQUE; # just in case...
2456
2457 if (ref $channel) {
2458 # send meta info to client, if not yet sent
2459 unless (exists $self->{channel}{$channel->{id}}) {
2460 $self->{channel}{$channel->{id}} = $channel;
2461 $self->ext_event (channel_info => %$channel);
2462 }
2463
2464 $channel = $channel->{id};
2465 }
2466
2467 return unless @extra || length $msg;
2468
2469 if ($self->can_msg) {
2470 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $channel, $msg, @extra]));
2471 } else {
2472 # replace some tags by gcfclient-compatible ones
2473 for ($msg) {
2474 1 while
2475 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2476 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2477 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2478 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2479 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2480 }
2481
2482 if ($color >= 0) {
2483 if (0 && $msg =~ /\[/) {
2484 $self->send_packet ("drawextinfo $color 4 0 $msg")
2485 } else {
2486 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2487 $self->send_packet ("drawinfo $color $msg")
2488 }
2489 }
2490 }
2491}
2492
2493=item $client->ext_event ($type, %msg)
2494
2495Sends an ext event to the client.
2496
2497=cut
2498
2499sub cf::client::ext_event($$%) {
2500 my ($self, $type, %msg) = @_;
2501
2502 return unless $self->extcmd;
2503
2504 $msg{msgtype} = "event_$type";
2505 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2506}
1900 2507
1901=item $success = $client->query ($flags, "text", \&cb) 2508=item $success = $client->query ($flags, "text", \&cb)
1902 2509
1903Queues a query to the client, calling the given callback with 2510Queues a query to the client, calling the given callback with
1904the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2511the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1905C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2512C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1906 2513
1907Queries can fail, so check the return code. Or don't, as queries will become 2514Queries can fail, so check the return code. Or don't, as queries will
1908reliable at some point in the future. 2515become reliable at some point in the future.
1909 2516
1910=cut 2517=cut
1911 2518
1912sub cf::client::query { 2519sub cf::client::query {
1913 my ($self, $flags, $text, $cb) = @_; 2520 my ($self, $flags, $text, $cb) = @_;
… …
1921 utf8::encode $text; 2528 utf8::encode $text;
1922 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2529 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1923 2530
1924 $self->send_packet ($self->{query_queue}[0][0]) 2531 $self->send_packet ($self->{query_queue}[0][0])
1925 if @{ $self->{query_queue} } == 1; 2532 if @{ $self->{query_queue} } == 1;
2533
2534 1
1926} 2535}
1927 2536
1928cf::client->attach ( 2537cf::client->attach (
2538 on_connect => sub {
2539 my ($ns) = @_;
2540
2541 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2542 },
1929 on_reply => sub { 2543 on_reply => sub {
1930 my ($ns, $msg) = @_; 2544 my ($ns, $msg) = @_;
1931 2545
1932 # this weird shuffling is so that direct followup queries 2546 # this weird shuffling is so that direct followup queries
1933 # get handled first 2547 # get handled first
1934 my $queue = delete $ns->{query_queue} 2548 my $queue = delete $ns->{query_queue}
1935 or return; # be conservative, not sure how that can happen, but we saw a crash here 2549 or return; # be conservative, not sure how that can happen, but we saw a crash here
1936 2550
1937 (shift @$queue)->[1]->($msg); 2551 (shift @$queue)->[1]->($msg);
2552 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1938 2553
1939 push @{ $ns->{query_queue} }, @$queue; 2554 push @{ $ns->{query_queue} }, @$queue;
1940 2555
1941 if (@{ $ns->{query_queue} } == @$queue) { 2556 if (@{ $ns->{query_queue} } == @$queue) {
1942 if (@$queue) { 2557 if (@$queue) {
… …
1944 } else { 2559 } else {
1945 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2560 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1946 } 2561 }
1947 } 2562 }
1948 }, 2563 },
2564 on_exticmd => sub {
2565 my ($ns, $buf) = @_;
2566
2567 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2568
2569 if (ref $msg) {
2570 if (my $cb = $EXTICMD{$msg->{msgtype}}) {
2571 if (my %reply = $cb->($ns, $msg)) {
2572 $reply{msgid} = $msg->{msgid};
2573 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2574 }
2575 }
2576 } else {
2577 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2578 }
2579
2580 cf::override;
2581 },
1949); 2582);
1950 2583
1951=item $client->async (\&cb) 2584=item $client->async (\&cb)
1952 2585
1953Create a new coroutine, running the specified callback. The coroutine will 2586Create a new coroutine, running the specified callback. The coroutine will
… …
2000 2633
2001# here we export the classes and methods available to script code 2634# here we export the classes and methods available to script code
2002 2635
2003=pod 2636=pod
2004 2637
2005The following fucntions and emthods are available within a safe environment: 2638The following functions and methods are available within a safe environment:
2006 2639
2007 cf::object contr pay_amount pay_player map 2640 cf::object
2641 contr pay_amount pay_player map x y force_find force_add
2642 insert remove
2643
2008 cf::object::player player 2644 cf::object::player
2009 cf::player peaceful 2645 player
2010 cf::map trigger 2646
2647 cf::player
2648 peaceful
2649
2650 cf::map
2651 trigger
2011 2652
2012=cut 2653=cut
2013 2654
2014for ( 2655for (
2015 ["cf::object" => qw(contr pay_amount pay_player map)], 2656 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2657 insert remove)],
2016 ["cf::object::player" => qw(player)], 2658 ["cf::object::player" => qw(player)],
2017 ["cf::player" => qw(peaceful)], 2659 ["cf::player" => qw(peaceful)],
2018 ["cf::map" => qw(trigger)], 2660 ["cf::map" => qw(trigger)],
2019) { 2661) {
2020 no strict 'refs'; 2662 no strict 'refs';
… …
2091=back 2733=back
2092 2734
2093=cut 2735=cut
2094 2736
2095############################################################################# 2737#############################################################################
2738# the server's init and main functions
2096 2739
2097=head2 EXTENSION DATABASE SUPPORT 2740sub load_facedata($) {
2741 my ($path) = @_;
2098 2742
2099Crossfire maintains a very simple database for extension use. It can 2743 warn "loading facedata from $path\n";
2100currently store anything that can be serialised using Storable, which
2101excludes objects.
2102 2744
2103The parameter C<$family> should best start with the name of the extension 2745 my $facedata;
2104using it, it should be unique. 2746 0 < aio_load $path, $facedata
2747 or die "$path: $!";
2105 2748
2106=over 4 2749 $facedata = Coro::Storable::thaw $facedata;
2107 2750
2108=item $hashref = cf::db_get $family 2751 $facedata->{version} == 2
2752 or cf::cleanup "$path: version mismatch, cannot proceed.";
2109 2753
2110Return a hashref for use by the extension C<$family>, which can be
2111modified. After modifications, you have to call C<cf::db_dirty> or
2112C<cf::db_sync>.
2113
2114=item $value = cf::db_get $family => $key
2115
2116Returns a single value from the database
2117
2118=item cf::db_put $family => $hashref
2119
2120Stores the given family hashref into the database. Updates are delayed, if
2121you want the data to be synced to disk immediately, use C<cf::db_sync>.
2122
2123=item cf::db_put $family => $key => $value
2124
2125Stores the given C<$value> in the family hash. Updates are delayed, if you
2126want the data to be synced to disk immediately, use C<cf::db_sync>.
2127
2128=item cf::db_dirty
2129
2130Marks the database as dirty, to be updated at a later time.
2131
2132=item cf::db_sync
2133
2134Immediately write the database to disk I<if it is dirty>.
2135
2136=cut
2137
2138our $DB;
2139
2140{
2141 my $path = cf::localdir . "/database.pst";
2142
2143 sub db_load() {
2144 $DB = stat $path ? Storable::retrieve $path : { };
2145 } 2754 {
2755 my $faces = $facedata->{faceinfo};
2146 2756
2147 my $pid; 2757 while (my ($face, $info) = each %$faces) {
2758 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2759 cf::face::set_visibility $idx, $info->{visibility};
2760 cf::face::set_magicmap $idx, $info->{magicmap};
2761 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2762 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2148 2763
2149 sub db_save() { 2764 cf::cede_to_tick;
2150 waitpid $pid, 0 if $pid;
2151 if (0 == ($pid = fork)) {
2152 $DB->{_meta}{version} = 1;
2153 Storable::nstore $DB, "$path~";
2154 rename "$path~", $path;
2155 cf::_exit 0 if defined $pid;
2156 }
2157 }
2158
2159 my $dirty;
2160
2161 sub db_sync() {
2162 db_save if $dirty;
2163 undef $dirty;
2164 }
2165
2166 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
2167 db_sync;
2168 });
2169
2170 sub db_dirty() {
2171 $dirty = 1;
2172 $idle->start;
2173 }
2174
2175 sub db_get($;$) {
2176 @_ >= 2
2177 ? $DB->{$_[0]}{$_[1]}
2178 : ($DB->{$_[0]} ||= { })
2179 }
2180
2181 sub db_put($$;$) {
2182 if (@_ >= 3) {
2183 $DB->{$_[0]}{$_[1]} = $_[2];
2184 } else {
2185 $DB->{$_[0]} = $_[1];
2186 }
2187 db_dirty;
2188 }
2189
2190 cf::global->attach (
2191 prio => 10000,
2192 on_cleanup => sub {
2193 db_sync;
2194 }, 2765 }
2195 );
2196}
2197 2766
2198############################################################################# 2767 while (my ($face, $info) = each %$faces) {
2199# the server's main() 2768 next unless $info->{smooth};
2769 my $idx = cf::face::find $face
2770 or next;
2771 if (my $smooth = cf::face::find $info->{smooth}) {
2772 cf::face::set_smooth $idx, $smooth;
2773 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2774 } else {
2775 warn "smooth face '$info->{smooth}' not found for face '$face'";
2776 }
2777
2778 cf::cede_to_tick;
2779 }
2780 }
2781
2782 {
2783 my $anims = $facedata->{animinfo};
2784
2785 while (my ($anim, $info) = each %$anims) {
2786 cf::anim::set $anim, $info->{frames}, $info->{facings};
2787 cf::cede_to_tick;
2788 }
2789
2790 cf::anim::invalidate_all; # d'oh
2791 }
2792
2793 {
2794 # TODO: for gcfclient pleasure, we should give resources
2795 # that gcfclient doesn't grok a >10000 face index.
2796 my $res = $facedata->{resource};
2797 my $enc = JSON::XS->new->utf8->canonical;
2798
2799 while (my ($name, $info) = each %$res) {
2800 my $meta = $enc->encode ({
2801 name => $name,
2802 type => $info->{type},
2803 copyright => $info->{copyright}, #TODO#
2804 });
2805
2806 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2807
2808 if ($name =~ /\.jpg$/) {
2809 cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack
2810 cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack
2811 } else {
2812 my $data = pack "(w/a*)*", $meta, $info->{data};
2813 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2814
2815 cf::face::set_type $idx, 1;
2816 cf::face::set_data $idx, 0, $data, $chk;
2817 }
2818
2819 cf::cede_to_tick;
2820 }
2821 }
2822
2823 1
2824}
2825
2826sub reload_regions {
2827 load_resource_file "$MAPDIR/regions"
2828 or die "unable to load regions file\n";
2829
2830 for (cf::region::list) {
2831 $_->{match} = qr/$_->{match}/
2832 if exists $_->{match};
2833 }
2834}
2835
2836sub reload_facedata {
2837 load_facedata "$DATADIR/facedata"
2838 or die "unable to load facedata\n";
2839}
2840
2841sub reload_archetypes {
2842 load_resource_file "$DATADIR/archetypes"
2843 or die "unable to load archetypes\n";
2844 #d# NEED to laod twice to resolve forward references
2845 # this really needs to be done in an extra post-pass
2846 # (which needs to be synchronous, so solve it differently)
2847 load_resource_file "$DATADIR/archetypes"
2848 or die "unable to load archetypes\n";
2849}
2850
2851sub reload_treasures {
2852 load_resource_file "$DATADIR/treasures"
2853 or die "unable to load treasurelists\n";
2854}
2855
2856sub reload_resources {
2857 warn "reloading resource files...\n";
2858
2859 reload_regions;
2860 reload_facedata;
2861 #reload_archetypes;#d#
2862 reload_archetypes;
2863 reload_treasures;
2864
2865 warn "finished reloading resource files\n";
2866}
2867
2868sub init {
2869 reload_resources;
2870}
2200 2871
2201sub cfg_load { 2872sub cfg_load {
2202 open my $fh, "<:utf8", cf::confdir . "/config" 2873 open my $fh, "<:utf8", "$CONFDIR/config"
2203 or return; 2874 or return;
2204 2875
2205 local $/; 2876 local $/;
2206 *CFG = YAML::Syck::Load <$fh>; 2877 *CFG = YAML::Syck::Load <$fh>;
2207 2878
… …
2221 2892
2222sub main { 2893sub main {
2223 # we must not ever block the main coroutine 2894 # we must not ever block the main coroutine
2224 local $Coro::idle = sub { 2895 local $Coro::idle = sub {
2225 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 2896 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2897 (async {
2226 async { Event::one_event }; 2898 Event::one_event;
2899 })->prio (Coro::PRIO_MAX);
2227 }; 2900 };
2228 2901
2229 cfg_load; 2902 cfg_load;
2230 db_load; 2903 db_init;
2231 load_extensions; 2904 load_extensions;
2905
2906 $TICK_WATCHER->start;
2232 Event::loop; 2907 Event::loop;
2233} 2908}
2234 2909
2235############################################################################# 2910#############################################################################
2236# initialisation and cleanup 2911# initialisation and cleanup
2237 2912
2238# install some emergency cleanup handlers 2913# install some emergency cleanup handlers
2239BEGIN { 2914BEGIN {
2240 for my $signal (qw(INT HUP TERM)) { 2915 for my $signal (qw(INT HUP TERM)) {
2241 Event->signal ( 2916 Event->signal (
2917 reentrant => 0,
2242 data => WF_AUTOCANCEL, 2918 data => WF_AUTOCANCEL,
2243 signal => $signal, 2919 signal => $signal,
2920 prio => 0,
2244 cb => sub { 2921 cb => sub {
2245 cf::cleanup "SIG$signal"; 2922 cf::cleanup "SIG$signal";
2246 }, 2923 },
2247 ); 2924 );
2248 } 2925 }
2249} 2926}
2250 2927
2928sub write_runtime {
2929 my $runtime = "$LOCALDIR/runtime";
2930
2931 # first touch the runtime file to show we are still running:
2932 # the fsync below can take a very very long time.
2933
2934 IO::AIO::aio_utime $runtime, undef, undef;
2935
2936 my $guard = cf::lock_acquire "write_runtime";
2937
2938 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2939 or return;
2940
2941 my $value = $cf::RUNTIME + 90 + 10;
2942 # 10 is the runtime save interval, for a monotonic clock
2943 # 60 allows for the watchdog to kill the server.
2944
2945 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2946 and return;
2947
2948 # always fsync - this file is important
2949 aio_fsync $fh
2950 and return;
2951
2952 # touch it again to show we are up-to-date
2953 aio_utime $fh, undef, undef;
2954
2955 close $fh
2956 or return;
2957
2958 aio_rename "$runtime~", $runtime
2959 and return;
2960
2961 warn "runtime file written.\n";
2962
2963 1
2964}
2965
2251sub emergency_save() { 2966sub emergency_save() {
2252 my $freeze_guard = cf::freeze_mainloop; 2967 my $freeze_guard = cf::freeze_mainloop;
2253 2968
2254 warn "enter emergency perl save\n"; 2969 warn "enter emergency perl save\n";
2255 2970
2256 cf::sync_job { 2971 cf::sync_job {
2257 # use a peculiar iteration method to avoid tripping on perl 2972 # use a peculiar iteration method to avoid tripping on perl
2258 # refcount bugs in for. also avoids problems with players 2973 # refcount bugs in for. also avoids problems with players
2259 # and maps saved/Destroyed asynchronously. 2974 # and maps saved/destroyed asynchronously.
2260 warn "begin emergency player save\n"; 2975 warn "begin emergency player save\n";
2261 for my $login (keys %cf::PLAYER) { 2976 for my $login (keys %cf::PLAYER) {
2262 my $pl = $cf::PLAYER{$login} or next; 2977 my $pl = $cf::PLAYER{$login} or next;
2263 $pl->valid or next; 2978 $pl->valid or next;
2264 $pl->save; 2979 $pl->save;
… …
2270 my $map = $cf::MAP{$path} or next; 2985 my $map = $cf::MAP{$path} or next;
2271 $map->valid or next; 2986 $map->valid or next;
2272 $map->save; 2987 $map->save;
2273 } 2988 }
2274 warn "end emergency map save\n"; 2989 warn "end emergency map save\n";
2990
2991 warn "begin emergency database checkpoint\n";
2992 BDB::db_env_txn_checkpoint $DB_ENV;
2993 warn "end emergency database checkpoint\n";
2275 }; 2994 };
2276 2995
2277 warn "leave emergency perl save\n"; 2996 warn "leave emergency perl save\n";
2278} 2997}
2279 2998
2999sub post_cleanup {
3000 my ($make_core) = @_;
3001
3002 warn Carp::longmess "post_cleanup backtrace"
3003 if $make_core;
3004}
3005
2280sub reload() { 3006sub do_reload_perl() {
2281 # can/must only be called in main 3007 # can/must only be called in main
2282 if ($Coro::current != $Coro::main) { 3008 if ($Coro::current != $Coro::main) {
2283 warn "can only reload from main coroutine\n"; 3009 warn "can only reload from main coroutine";
2284 return; 3010 return;
2285 } 3011 }
2286 3012
2287 warn "reloading..."; 3013 warn "reloading...";
2288 3014
2289 warn "freezing server"; 3015 warn "entering sync_job";
2290 my $guard = freeze_mainloop; 3016
3017 cf::sync_job {
3018 cf::write_runtime; # external watchdog should not bark
2291 cf::emergency_save; 3019 cf::emergency_save;
3020 cf::write_runtime; # external watchdog should not bark
2292 3021
2293 warn "sync database to disk"; 3022 warn "syncing database to disk";
2294 cf::db_sync; 3023 BDB::db_env_txn_checkpoint $DB_ENV;
2295 IO::AIO::flush;
2296 3024
2297 eval {
2298 # if anything goes wrong in here, we should simply crash as we already saved 3025 # if anything goes wrong in here, we should simply crash as we already saved
2299 3026
2300 warn "cancel all watchers"; 3027 warn "cancelling all WF_AUTOCANCEL watchers";
2301 for (Event::all_watchers) { 3028 for (Event::all_watchers) {
2302 $_->cancel if $_->data & WF_AUTOCANCEL; 3029 $_->cancel if $_->data & WF_AUTOCANCEL;
2303 } 3030 }
2304 3031
3032 warn "flushing outstanding aio requests";
3033 for (;;) {
3034 BDB::flush;
3035 IO::AIO::flush;
3036 Coro::cede;
3037 last unless IO::AIO::nreqs || BDB::nreqs;
3038 warn "iterate...";
3039 }
3040
3041 ++$RELOAD;
3042
2305 warn "cancel all extension coros"; 3043 warn "cancelling all extension coros";
2306 $_->cancel for values %EXT_CORO; 3044 $_->cancel for values %EXT_CORO;
2307 %EXT_CORO = (); 3045 %EXT_CORO = ();
2308 3046
2309 warn "remove commands"; 3047 warn "removing commands";
2310 %COMMAND = (); 3048 %COMMAND = ();
2311 3049
2312 warn "remove ext commands"; 3050 warn "removing ext/exti commands";
2313 %EXTCMD = (); 3051 %EXTCMD = ();
3052 %EXTICMD = ();
2314 3053
2315 warn "unload/nuke all extensions"; 3054 warn "unloading/nuking all extensions";
2316 for my $pkg (@EXTS) { 3055 for my $pkg (@EXTS) {
2317 warn "... unloading $pkg"; 3056 warn "... unloading $pkg";
2318 3057
2319 if (my $cb = $pkg->can ("unload")) { 3058 if (my $cb = $pkg->can ("unload")) {
2320 eval { 3059 eval {
… …
2325 3064
2326 warn "... nuking $pkg"; 3065 warn "... nuking $pkg";
2327 Symbol::delete_package $pkg; 3066 Symbol::delete_package $pkg;
2328 } 3067 }
2329 3068
2330 warn "unload all perl modules loaded from $LIBDIR"; 3069 warn "unloading all perl modules loaded from $LIBDIR";
2331 while (my ($k, $v) = each %INC) { 3070 while (my ($k, $v) = each %INC) {
2332 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3071 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2333 3072
2334 warn "removing <$k>"; 3073 warn "... unloading $k";
2335 delete $INC{$k}; 3074 delete $INC{$k};
2336 3075
2337 $k =~ s/\.pm$//; 3076 $k =~ s/\.pm$//;
2338 $k =~ s/\//::/g; 3077 $k =~ s/\//::/g;
2339 3078
… …
2342 } 3081 }
2343 3082
2344 Symbol::delete_package $k; 3083 Symbol::delete_package $k;
2345 } 3084 }
2346 3085
2347 warn "get rid of safe::, as good as possible"; 3086 warn "getting rid of safe::, as good as possible";
2348 Symbol::delete_package "safe::$_" 3087 Symbol::delete_package "safe::$_"
2349 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3088 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2350 3089
2351 warn "unload cf.pm \"a bit\""; 3090 warn "unloading cf.pm \"a bit\"";
2352 delete $INC{"cf.pm"}; 3091 delete $INC{"cf.pm"};
3092 delete $INC{"cf/pod.pm"};
2353 3093
2354 # don't, removes xs symbols, too, 3094 # don't, removes xs symbols, too,
2355 # and global variables created in xs 3095 # and global variables created in xs
2356 #Symbol::delete_package __PACKAGE__; 3096 #Symbol::delete_package __PACKAGE__;
2357 3097
3098 warn "unload completed, starting to reload now";
3099
2358 warn "reloading cf.pm"; 3100 warn "reloading cf.pm";
2359 require cf; 3101 require cf;
2360 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3102 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2361 3103
2362 warn "load config and database again"; 3104 warn "loading config and database again";
2363 cf::cfg_load; 3105 cf::cfg_load;
2364 cf::db_load;
2365 3106
2366 warn "load extensions"; 3107 warn "loading extensions";
2367 cf::load_extensions; 3108 cf::load_extensions;
2368 3109
2369 warn "reattach attachments to objects/players"; 3110 warn "reattaching attachments to objects/players";
2370 _global_reattach; 3111 _global_reattach; # objects, sockets
2371 warn "reattach attachments to maps"; 3112 warn "reattaching attachments to maps";
2372 reattach $_ for values %MAP; 3113 reattach $_ for values %MAP;
2373 }; 3114 warn "reattaching attachments to players";
3115 reattach $_ for values %PLAYER;
2374 3116
2375 if ($@) { 3117 warn "leaving sync_job";
3118
3119 1
3120 } or do {
2376 warn $@; 3121 warn $@;
2377 warn "error while reloading, exiting."; 3122 warn "error while reloading, exiting.";
2378 exit 1; 3123 exit 1;
2379 } 3124 };
2380 3125
2381 warn "reloaded"; 3126 warn "reloaded";
2382}; 3127};
2383 3128
3129our $RELOAD_WATCHER; # used only during reload
3130
3131sub reload_perl() {
3132 # doing reload synchronously and two reloads happen back-to-back,
3133 # coro crashes during coro_state_free->destroy here.
3134
3135 $RELOAD_WATCHER ||= Event->timer (
3136 reentrant => 0,
3137 after => 0,
3138 data => WF_AUTOCANCEL,
3139 cb => sub {
3140 do_reload_perl;
3141 undef $RELOAD_WATCHER;
3142 },
3143 );
3144}
3145
2384register_command "reload" => sub { 3146register_command "reload" => sub {
2385 my ($who, $arg) = @_; 3147 my ($who, $arg) = @_;
2386 3148
2387 if ($who->flag (FLAG_WIZ)) { 3149 if ($who->flag (FLAG_WIZ)) {
2388 $who->message ("start of reload.");
2389 reload;
2390 $who->message ("end of reload."); 3150 $who->message ("reloading server.");
3151 async { reload_perl };
2391 } 3152 }
2392}; 3153};
2393 3154
2394unshift @INC, $LIBDIR; 3155unshift @INC, $LIBDIR;
2395 3156
3157my $bug_warning = 0;
3158
3159our @WAIT_FOR_TICK;
3160our @WAIT_FOR_TICK_BEGIN;
3161
3162sub wait_for_tick {
3163 return unless $TICK_WATCHER->is_active;
3164 return if $Coro::current == $Coro::main;
3165
3166 my $signal = new Coro::Signal;
3167 push @WAIT_FOR_TICK, $signal;
3168 $signal->wait;
3169}
3170
3171sub wait_for_tick_begin {
3172 return unless $TICK_WATCHER->is_active;
3173 return if $Coro::current == $Coro::main;
3174
3175 my $signal = new Coro::Signal;
3176 push @WAIT_FOR_TICK_BEGIN, $signal;
3177 $signal->wait;
3178}
3179
3180 my $min = 1e6;#d#
3181 my $avg = 10;
2396$TICK_WATCHER = Event->timer ( 3182$TICK_WATCHER = Event->timer (
2397 reentrant => 0, 3183 reentrant => 0,
3184 parked => 1,
2398 prio => 0, 3185 prio => 0,
2399 at => $NEXT_TICK || $TICK, 3186 at => $NEXT_TICK || $TICK,
2400 data => WF_AUTOCANCEL, 3187 data => WF_AUTOCANCEL,
2401 cb => sub { 3188 cb => sub {
3189 if ($Coro::current != $Coro::main) {
3190 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3191 unless ++$bug_warning > 10;
3192 return;
3193 }
3194
2402 $NOW = Event::time; 3195 $NOW = $tick_start = Event::time;
2403 3196
2404 cf::server_tick; # one server iteration 3197 cf::server_tick; # one server iteration
3198
3199 0 && sync_job {#d#
3200 for(1..10) {
3201 my $t = Event::time;
3202 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3203 or die;
3204
3205 $map->width (50);
3206 $map->height (50);
3207 $map->alloc;
3208 $map->_load_objects ("/tmp/x.map", 1);
3209 my $t = Event::time - $t;
3210
3211 #next unless $t < 0.0013;#d#
3212 if ($t < $min) {
3213 $min = $t;
3214 }
3215 $avg = $avg * 0.99 + $t * 0.01;
3216 }
3217 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3218 exit 0;
3219 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3220 };
3221
2405 $RUNTIME += $TICK; 3222 $RUNTIME += $TICK;
2406 $NEXT_TICK += $TICK; 3223 $NEXT_TICK += $TICK;
2407 3224
2408 $WAIT_FOR_TICK->broadcast; 3225 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2409 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited; 3226 $NEXT_RUNTIME_WRITE = $NOW + 10;
3227 Coro::async_pool {
3228 write_runtime
3229 or warn "ERROR: unable to write runtime file: $!";
3230 };
3231 }
3232
3233# my $AFTER = Event::time;
3234# warn $AFTER - $NOW;#d#
3235
3236 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3237 $sig->send;
3238 }
3239 while (my $sig = shift @WAIT_FOR_TICK) {
3240 $sig->send;
3241 }
3242
3243 $NOW = Event::time;
2410 3244
2411 # if we are delayed by four ticks or more, skip them all 3245 # if we are delayed by four ticks or more, skip them all
2412 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3246 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2413 3247
2414 $TICK_WATCHER->at ($NEXT_TICK); 3248 $TICK_WATCHER->at ($NEXT_TICK);
2415 $TICK_WATCHER->start; 3249 $TICK_WATCHER->start;
3250
3251 $LOAD = ($NOW - $tick_start) / $TICK;
3252 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3253
3254 _post_tick;
3255
3256
2416 }, 3257 },
2417); 3258);
2418 3259
3260{
2419IO::AIO::max_poll_time $TICK * 0.2; 3261 BDB::max_poll_time $TICK * 0.1;
2420 3262 $BDB_POLL_WATCHER = Event->io (
2421Event->io ( 3263 reentrant => 0,
2422 fd => IO::AIO::poll_fileno, 3264 fd => BDB::poll_fileno,
2423 poll => 'r', 3265 poll => 'r',
2424 prio => 5, 3266 prio => 0,
2425 data => WF_AUTOCANCEL,
2426 cb => \&IO::AIO::poll_cb,
2427);
2428
2429Event->timer (
2430 data => WF_AUTOCANCEL, 3267 data => WF_AUTOCANCEL,
2431 after => 0, 3268 cb => \&BDB::poll_cb,
2432 interval => 10, 3269 );
2433 cb => sub { 3270 BDB::min_parallel 8;
2434 (Coro::unblock_sub { 3271
2435 write_runtime 3272 BDB::set_sync_prepare {
2436 or warn "ERROR: unable to write runtime file: $!"; 3273 my $status;
3274 my $current = $Coro::current;
3275 (
3276 sub {
3277 $status = $!;
3278 $current->ready; undef $current;
3279 },
3280 sub {
3281 Coro::schedule while defined $current;
3282 $! = $status;
3283 },
3284 )
3285 };
3286
3287 unless ($DB_ENV) {
3288 $DB_ENV = BDB::db_env_create;
3289
3290 cf::sync_job {
3291 eval {
3292 BDB::db_env_open
3293 $DB_ENV,
3294 $BDBDIR,
3295 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3296 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3297 0666;
3298
3299 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3300
3301 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3302 $DB_ENV->set_lk_detect;
3303 };
3304
3305 cf::cleanup "db_env_open(db): $@" if $@;
2437 })->(); 3306 };
2438 }, 3307 }
2439); 3308}
3309
3310{
3311 IO::AIO::min_parallel 8;
3312
3313 undef $Coro::AIO::WATCHER;
3314 IO::AIO::max_poll_time $TICK * 0.1;
3315 $AIO_POLL_WATCHER = Event->io (
3316 reentrant => 0,
3317 data => WF_AUTOCANCEL,
3318 fd => IO::AIO::poll_fileno,
3319 poll => 'r',
3320 prio => 6,
3321 cb => \&IO::AIO::poll_cb,
3322 );
3323}
3324
3325my $_log_backtrace;
3326
3327sub _log_backtrace {
3328 my ($msg, @addr) = @_;
3329
3330 $msg =~ s/\n//;
3331
3332 # limit the # of concurrent backtraces
3333 if ($_log_backtrace < 2) {
3334 ++$_log_backtrace;
3335 async {
3336 my @bt = fork_call {
3337 @addr = map { sprintf "%x", $_ } @addr;
3338 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3339 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3340 or die "addr2line: $!";
3341
3342 my @funcs;
3343 my @res = <$fh>;
3344 chomp for @res;
3345 while (@res) {
3346 my ($func, $line) = splice @res, 0, 2, ();
3347 push @funcs, "[$func] $line";
3348 }
3349
3350 @funcs
3351 };
3352
3353 LOG llevInfo, "[ABT] $msg\n";
3354 LOG llevInfo, "[ABT] $_\n" for @bt;
3355 --$_log_backtrace;
3356 };
3357 } else {
3358 LOG llevInfo, "[ABT] $msg\n";
3359 LOG llevInfo, "[ABT] [suppressed]\n";
3360 }
3361}
3362
3363# load additional modules
3364use cf::pod;
2440 3365
2441END { cf::emergency_save } 3366END { cf::emergency_save }
2442 3367
24431 33681
2444 3369

Diff Legend

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