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.70 by root, Sun Oct 1 10:55:37 2006 UTC vs.
Revision 1.276 by root, Sun Jun 10 04:05:47 2007 UTC

1package cf; 1package cf;
2
3use utf8;
4use strict;
2 5
3use Symbol; 6use Symbol;
4use List::Util; 7use List::Util;
8use Socket;
5use Storable; 9use Storable;
10use Event;
6use Opcode; 11use Opcode;
7use Safe; 12use Safe;
8use Safe::Hole; 13use Safe::Hole;
9 14
15use Coro 3.61 ();
16use Coro::State;
17use Coro::Handle;
18use Coro::Event;
19use Coro::Timer;
20use Coro::Signal;
21use Coro::Semaphore;
22use Coro::AIO;
23use Coro::Storable;
24
25use BDB ();
26use Data::Dumper;
27use Digest::MD5;
28use Fcntl;
29use YAML::Syck ();
30use IO::AIO 2.32 ();
10use Time::HiRes; 31use Time::HiRes;
11use Event; 32use Compress::LZF;
33
34# configure various modules to our taste
35#
36$Storable::canonical = 1; # reduce rsync transfers
37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
38Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
39
12$Event::Eval = 1; # no idea why this is required, but it is 40$Event::Eval = 1; # no idea why this is required, but it is
13 41
14use strict; 42# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
43$YAML::Syck::ImplicitUnicode = 1;
15 44
16_init_vars; 45$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
17 46
47sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
48
18our %COMMAND = (); 49our %COMMAND = ();
50our %COMMAND_TIME = ();
51
52our @EXTS = (); # list of extension package names
53our %EXTCMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps
56
57our $RELOAD; # number of reloads so far
19our @EVENT; 58our @EVENT;
20our $LIBDIR = maps_directory "perl";
21 59
22our $TICK = MAX_TIME * 1e-6; 60our $CONFDIR = confdir;
61our $DATADIR = datadir;
62our $LIBDIR = "$DATADIR/ext";
63our $PODDIR = "$DATADIR/pod";
64our $MAPDIR = "$DATADIR/" . mapdir;
65our $LOCALDIR = localdir;
66our $TMPDIR = "$LOCALDIR/" . tmpdir;
67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
68our $PLAYERDIR = "$LOCALDIR/" . playerdir;
69our $RANDOMDIR = "$LOCALDIR/random";
70our $BDBDIR = "$LOCALDIR/db";
71
72our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
23our $TICK_WATCHER; 73our $TICK_WATCHER;
74our $AIO_POLL_WATCHER;
75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
24our $NEXT_TICK; 76our $NEXT_TICK;
77our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off
79
80our $BDB_POLL_WATCHER;
81our $DB_ENV;
25 82
26our %CFG; 83our %CFG;
27 84
85our $UPTIME; $UPTIME ||= time;
86our $RUNTIME;
87
88our %PLAYER; # all users
89our %MAP; # all maps
90our $LINK_MAP; # the special {link} map, which is always available
91
92# used to convert map paths into valid unix filenames by replacing / by ∕
93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
94
95our $LOAD; # a number between 0 (idle) and 1 (too many objects)
96our $LOADAVG; # same thing, but with alpha-smoothing
97our $tick_start; # for load detecting purposes
98
99binmode STDOUT;
100binmode STDERR;
101
102# read virtual server time, if available
103unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
104 open my $fh, "<", "$LOCALDIR/runtime"
105 or die "unable to read runtime file: $!";
106 $RUNTIME = <$fh> + 0.;
107}
108
109mkdir $_
110 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
111
112our $EMERGENCY_POSITION;
113
114sub cf::map::normalise;
115
28############################################################################# 116#############################################################################
29 117
30=head2 GLOBAL VARIABLES 118=head2 GLOBAL VARIABLES
31 119
32=over 4 120=over 4
33 121
34=item $cf::LIBDIR 122=item $cf::UPTIME
35 123
36The perl library directory, where extensions and cf-specific modules can 124The timestamp of the server start (so not actually an uptime).
37be found. It will be added to C<@INC> automatically. 125
126=item $cf::RUNTIME
127
128The time this server has run, starts at 0 and is increased by $cf::TICK on
129every server tick.
130
131=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
132$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
133$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
134
135Various directories - "/etc", read-only install directory, perl-library
136directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
137unique-items directory, player file directory, random maps directory and
138database environment.
139
140=item $cf::NOW
141
142The time of the last (current) server tick.
38 143
39=item $cf::TICK 144=item $cf::TICK
40 145
41The interval between server ticks, in seconds. 146The interval between server ticks, in seconds.
147
148=item $cf::LOADAVG
149
150The current CPU load on the server (alpha-smoothed), as a value between 0
151(none) and 1 (overloaded), indicating how much time is spent on processing
152objects per tick. Healthy values are < 0.5.
153
154=item $cf::LOAD
155
156The raw value load value from the last tick.
42 157
43=item %cf::CFG 158=item %cf::CFG
44 159
45Configuration for the server, loaded from C</etc/crossfire/config>, or 160Configuration for the server, loaded from C</etc/crossfire/config>, or
46from wherever your confdir points to. 161from wherever your confdir points to.
162
163=item cf::wait_for_tick, cf::wait_for_tick_begin
164
165These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
166returns directly I<after> the tick processing (and consequently, can only wake one process
167per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
47 168
48=back 169=back
49 170
50=cut 171=cut
51 172
52BEGIN { 173BEGIN {
53 *CORE::GLOBAL::warn = sub { 174 *CORE::GLOBAL::warn = sub {
54 my $msg = join "", @_; 175 my $msg = join "", @_;
176
55 $msg .= "\n" 177 $msg .= "\n"
56 unless $msg =~ /\n$/; 178 unless $msg =~ /\n$/;
57 179
58 print STDERR "cfperl: $msg"; 180 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
181
182 utf8::encode $msg;
59 LOG llevError, "cfperl: $msg"; 183 LOG llevError, $msg;
60 }; 184 };
61} 185}
62 186
187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
191@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
192@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
63@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 193@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
64 194
65# we bless all objects into (empty) derived classes to force a method lookup 195# we bless all objects into (empty) derived classes to force a method lookup
66# within the Safe compartment. 196# within the Safe compartment.
67for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) { 197for my $pkg (qw(
198 cf::global cf::attachable
199 cf::object cf::object::player
200 cf::client cf::player
201 cf::arch cf::living
202 cf::map cf::party cf::region
203)) {
68 no strict 'refs'; 204 no strict 'refs';
69 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 205 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
70} 206}
71 207
72$Event::DIED = sub { 208$Event::DIED = sub {
73 warn "error in event callback: @_"; 209 warn "error in event callback: @_";
74}; 210};
75 211
76my %ext_pkg;
77my @exts;
78my @hook;
79my %command;
80my %extcmd;
81
82=head2 UTILITY FUNCTIONS 212=head2 UTILITY FUNCTIONS
83 213
84=over 4 214=over 4
85 215
86=cut 216=item dumpval $ref
87 217
218=cut
219
220sub dumpval {
221 eval {
222 local $SIG{__DIE__};
223 my $d;
224 if (1) {
225 $d = new Data::Dumper([$_[0]], ["*var"]);
226 $d->Terse(1);
227 $d->Indent(2);
228 $d->Quotekeys(0);
229 $d->Useqq(1);
230 #$d->Bless(...);
231 $d->Seen($_[1]) if @_ > 1;
232 $d = $d->Dump();
233 }
234 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
235 $d
236 } || "[unable to dump $_[0]: '$@']";
237}
238
88use JSON::Syck (); # TODO# replace by JSON::PC once working 239use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
89 240
90=item $ref = cf::from_json $json 241=item $ref = cf::from_json $json
91 242
92Converts a JSON string into the corresponding perl data structure. 243Converts a JSON string into the corresponding perl data structure.
93 244
94=cut
95
96sub from_json($) {
97 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
98 JSON::Syck::Load $_[0]
99}
100
101=item $json = cf::to_json $ref 245=item $json = cf::to_json $ref
102 246
103Converts a perl data structure into its JSON representation. 247Converts a perl data structure into its JSON representation.
104 248
105=cut 249=item cf::lock_wait $string
106 250
107sub to_json($) { 251Wait until the given lock is available. See cf::lock_acquire.
108 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 252
109 JSON::Syck::Dump $_[0] 253=item my $lock = cf::lock_acquire $string
254
255Wait until the given lock is available and then acquires it and returns
256a Coro::guard object. If the guard object gets destroyed (goes out of scope,
257for example when the coroutine gets canceled), the lock is automatically
258returned.
259
260Lock names should begin with a unique identifier (for example, cf::map::find
261uses map_find and cf::map::load uses map_load).
262
263=item $locked = cf::lock_active $string
264
265Return true if the lock is currently active, i.e. somebody has locked it.
266
267=cut
268
269our %LOCK;
270
271sub lock_wait($) {
272 my ($key) = @_;
273
274 # wait for lock, if any
275 while ($LOCK{$key}) {
276 push @{ $LOCK{$key} }, $Coro::current;
277 Coro::schedule;
278 }
279}
280
281sub lock_acquire($) {
282 my ($key) = @_;
283
284 # wait, to be sure we are not locked
285 lock_wait $key;
286
287 $LOCK{$key} = [];
288
289 Coro::guard {
290 # wake up all waiters, to be on the safe side
291 $_->ready for @{ delete $LOCK{$key} };
292 }
293}
294
295sub lock_active($) {
296 my ($key) = @_;
297
298 ! ! $LOCK{$key}
299}
300
301sub freeze_mainloop {
302 return unless $TICK_WATCHER->is_active;
303
304 my $guard = Coro::guard {
305 $TICK_WATCHER->start;
306 };
307 $TICK_WATCHER->stop;
308 $guard
309}
310
311=item cf::async { BLOCK }
312
313Currently the same as Coro::async_pool, meaning you cannot use
314C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
315thing you are allowed to do is call C<prio> on it.
316
317=cut
318
319BEGIN { *async = \&Coro::async_pool }
320
321=item cf::sync_job { BLOCK }
322
323The design of crossfire+ requires that the main coro ($Coro::main) is
324always able to handle events or runnable, as crossfire+ is only partly
325reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.
326
327If it must be done, put the blocking parts into C<sync_job>. This will run
328the given BLOCK in another coroutine while waiting for the result. The
329server will be frozen during this time, so the block should either finish
330fast or be very important.
331
332=cut
333
334sub sync_job(&) {
335 my ($job) = @_;
336
337 if ($Coro::current == $Coro::main) {
338 my $time = Event::time;
339
340 # this is the main coro, too bad, we have to block
341 # till the operation succeeds, freezing the server :/
342
343 # TODO: use suspend/resume instead
344 # (but this is cancel-safe)
345 my $freeze_guard = freeze_mainloop;
346
347 my $busy = 1;
348 my @res;
349
350 (async {
351 @res = eval { $job->() };
352 warn $@ if $@;
353 undef $busy;
354 })->prio (Coro::PRIO_MAX);
355
356 while ($busy) {
357 Coro::cede or Event::one_event;
358 }
359
360 $time = Event::time - $time;
361
362 LOG llevError | logBacktrace, Carp::longmess "long sync job"
363 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
364
365 $tick_start += $time; # do not account sync jobs to server load
366
367 wantarray ? @res : $res[0]
368 } else {
369 # we are in another coroutine, how wonderful, everything just works
370
371 $job->()
372 }
373}
374
375=item $coro = cf::async_ext { BLOCK }
376
377Like async, but this coro is automatically being canceled when the
378extension calling this is being unloaded.
379
380=cut
381
382sub async_ext(&) {
383 my $cb = shift;
384
385 my $coro = &Coro::async ($cb);
386
387 $coro->on_destroy (sub {
388 delete $EXT_CORO{$coro+0};
389 });
390 $EXT_CORO{$coro+0} = $coro;
391
392 $coro
393}
394
395sub write_runtime {
396 my $runtime = "$LOCALDIR/runtime";
397
398 # first touch the runtime file to show we are still running:
399 # the fsync below can take a very very long time.
400
401 IO::AIO::aio_utime $runtime, undef, undef;
402
403 my $guard = cf::lock_acquire "write_runtime";
404
405 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
406 or return;
407
408 my $value = $cf::RUNTIME + 90 + 10;
409 # 10 is the runtime save interval, for a monotonic clock
410 # 60 allows for the watchdog to kill the server.
411
412 (aio_write $fh, 0, (length $value), $value, 0) <= 0
413 and return;
414
415 # always fsync - this file is important
416 aio_fsync $fh
417 and return;
418
419 # touch it again to show we are up-to-date
420 aio_utime $fh, undef, undef;
421
422 close $fh
423 or return;
424
425 aio_rename "$runtime~", $runtime
426 and return;
427
428 warn "runtime file written.\n";
429
430 1
431}
432
433=item cf::datalog type => key => value, ...
434
435Log a datalog packet of the given type with the given key-value pairs.
436
437=cut
438
439sub datalog($@) {
440 my ($type, %kv) = @_;
441 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
110} 442}
111 443
112=back 444=back
113 445
446=cut
447
114############################################################################# 448#############################################################################
115 449
116=head2 EVENTS AND OBJECT ATTACHMENTS 450=head2 ATTACHABLE OBJECTS
451
452Many objects in crossfire are so-called attachable objects. That means you can
453attach callbacks/event handlers (a collection of which is called an "attachment")
454to it. All such attachable objects support the following methods.
455
456In the following description, CLASS can be any of C<global>, C<object>
457C<player>, C<client> or C<map> (i.e. the attachable objects in
458crossfire+).
117 459
118=over 4 460=over 4
119 461
120=item $object->attach ($attachment, key => $value...)
121
122=item $object->detach ($attachment)
123
124Attach/detach a pre-registered attachment to an object.
125
126=item $player->attach ($attachment, key => $value...)
127
128=item $player->detach ($attachment)
129
130Attach/detach a pre-registered attachment to a player.
131
132=item $map->attach ($attachment, key => $value...) 462=item $attachable->attach ($attachment, key => $value...)
133 463
134=item $map->detach ($attachment) 464=item $attachable->detach ($attachment)
135 465
136Attach/detach a pre-registered attachment to a map. 466Attach/detach a pre-registered attachment to a specific object and give it
467the specified key/value pairs as arguments.
137 468
138=item $bool = $object->attached ($name) 469Example, attach a minesweeper attachment to the given object, making it a
47010x10 minesweeper game:
139 471
140=item $bool = $player->attached ($name) 472 $obj->attach (minesweeper => width => 10, height => 10);
141 473
142=item $bool = $map->attached ($name) 474=item $bool = $attachable->attached ($name)
143 475
144Checks wether the named attachment is currently attached to the object. 476Checks wether the named attachment is currently attached to the object.
145 477
146=item cf::attach_global ... 478=item cf::CLASS->attach ...
147 479
148Attach handlers for global events. 480=item cf::CLASS->detach ...
149 481
150This and all following C<attach_*>-functions expect any number of the 482Define an anonymous attachment and attach it to all objects of the given
151following handler/hook descriptions: 483CLASS. See the next function for an explanation of its arguments.
484
485You can attach to global events by using the C<cf::global> class.
486
487Example, log all player logins:
488
489 cf::player->attach (
490 on_login => sub {
491 my ($pl) = @_;
492 ...
493 },
494 );
495
496Example, attach to the jeweler skill:
497
498 cf::object->attach (
499 type => cf::SKILL,
500 subtype => cf::SK_JEWELER,
501 on_use_skill => sub {
502 my ($sk, $ob, $part, $dir, $msg) = @_;
503 ...
504 },
505 );
506
507=item cf::CLASS::attachment $name, ...
508
509Register an attachment by C<$name> through which attachable objects of the
510given CLASS can refer to this attachment.
511
512Some classes such as crossfire maps and objects can specify attachments
513that are attached at load/instantiate time, thus the need for a name.
514
515These calls expect any number of the following handler/hook descriptions:
152 516
153=over 4 517=over 4
154 518
155=item prio => $number 519=item prio => $number
156 520
158by another C<prio> setting). Lower priority handlers get executed 522by another C<prio> setting). Lower priority handlers get executed
159earlier. The default priority is C<0>, and many built-in handlers are 523earlier. The default priority is C<0>, and many built-in handlers are
160registered at priority C<-1000>, so lower priorities should not be used 524registered at priority C<-1000>, so lower priorities should not be used
161unless you know what you are doing. 525unless you know what you are doing.
162 526
527=item type => $type
528
529(Only for C<< cf::object->attach >> calls), limits the attachment to the
530given type of objects only (the additional parameter C<subtype> can be
531used to further limit to the given subtype).
532
163=item on_I<event> => \&cb 533=item on_I<event> => \&cb
164 534
165Call the given code reference whenever the named event happens (event is 535Call the given code reference whenever the named event happens (event is
166something like C<instantiate>, C<apply>, C<use_skill> and so on, and which 536something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
167handlers are recognised generally depends on the type of object these 537handlers are recognised generally depends on the type of object these
176package and register them. Only handlers for eevents supported by the 546package and register them. Only handlers for eevents supported by the
177object/class are recognised. 547object/class are recognised.
178 548
179=back 549=back
180 550
181=item cf::attach_to_type $object_type, $subtype, ... 551Example, define an attachment called "sockpuppet" that calls the given
552event handler when a monster attacks:
182 553
183Attach handlers for a specific object type (e.g. TRANSPORT) and 554 cf::object::attachment sockpuppet =>
184subtype. If C<$subtype> is zero or undef, matches all objects of the given 555 on_skill_attack => sub {
185type. 556 my ($self, $victim) = @_;
186 557 ...
187=item cf::attach_to_objects ...
188
189Attach handlers to all objects. Do not use this except for debugging or
190very rare events, as handlers are (obviously) called for I<all> objects in
191the game.
192
193=item cf::attach_to_players ...
194
195Attach handlers to all players.
196
197=item cf::attach_to_maps ...
198
199Attach handlers to all maps.
200
201=item cf:register_attachment $name, ...
202
203Register an attachment by name through which objects can refer to this
204attachment.
205
206=item cf:register_player_attachment $name, ...
207
208Register an attachment by name through which players can refer to this
209attachment.
210
211=item cf:register_map_attachment $name, ...
212
213Register an attachment by name through which maps can refer to this
214attachment.
215
216=cut
217
218# the following variables are defined in .xs and must not be re-created
219our @CB_GLOBAL = (); # registry for all global events
220our @CB_OBJECT = (); # all objects (should not be used except in emergency)
221our @CB_PLAYER = ();
222our @CB_TYPE = (); # registry for type (cf-object class) based events
223our @CB_MAP = ();
224
225my %attachment;
226
227sub _attach_cb($\%$$$) {
228 my ($registry, $undo, $event, $prio, $cb) = @_;
229
230 use sort 'stable';
231
232 $cb = [$prio, $cb];
233
234 @{$registry->[$event]} = sort
235 { $a->[0] cmp $b->[0] }
236 @{$registry->[$event] || []}, $cb;
237
238 push @{$undo->{cb}}, [$event, $cb];
239}
240
241# attach handles attaching event callbacks
242# the only thing the caller has to do is pass the correct
243# registry (== where the callback attaches to).
244sub _attach(\@$@) {
245 my ($registry, $klass, @arg) = @_;
246
247 my $prio = 0;
248
249 my %undo = (
250 registry => $registry,
251 cb => [],
252 );
253
254 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
255
256 while (@arg) {
257 my $type = shift @arg;
258
259 if ($type eq "prio") {
260 $prio = shift @arg;
261
262 } elsif ($type eq "package") {
263 my $pkg = shift @arg;
264
265 while (my ($name, $id) = each %cb_id) {
266 if (my $cb = $pkg->can ($name)) {
267 _attach_cb $registry, %undo, $id, $prio, $cb;
268 }
269 } 558 }
270
271 } elsif (exists $cb_id{$type}) {
272 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg;
273
274 } elsif (ref $type) {
275 warn "attaching objects not supported, ignoring.\n";
276
277 } else {
278 shift @arg;
279 warn "attach argument '$type' not supported, ignoring.\n";
280 }
281 }
282
283 \%undo
284}
285
286sub _attach_attachment {
287 my ($obj, $name, %arg) = @_;
288
289 return if exists $obj->{_attachment}{$name};
290
291 my $res;
292
293 if (my $attach = $attachment{$name}) {
294 my $registry = $obj->registry;
295
296 for (@$attach) {
297 my ($klass, @attach) = @$_;
298 $res = _attach @$registry, $klass, @attach;
299 }
300
301 $obj->{$name} = \%arg;
302 } else {
303 warn "object uses attachment '$name' that is not available, postponing.\n";
304 }
305
306 $obj->{_attachment}{$name} = undef;
307
308 $res->{attachment} = $name;
309 $res
310}
311
312*cf::object::attach =
313*cf::player::attach =
314*cf::map::attach = sub {
315 my ($obj, $name, %arg) = @_;
316
317 _attach_attachment $obj, $name, %arg;
318};
319
320# all those should be optimised
321*cf::object::detach =
322*cf::player::detach =
323*cf::map::detach = sub {
324 my ($obj, $name) = @_;
325
326 delete $obj->{_attachment}{$name};
327 reattach ($obj);
328};
329
330*cf::object::attached =
331*cf::player::attached =
332*cf::map::attached = sub {
333 my ($obj, $name) = @_;
334
335 exists $obj->{_attachment}{$name}
336};
337
338sub attach_global {
339 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
340}
341
342sub attach_to_type {
343 my $type = shift;
344 my $subtype = shift;
345
346 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
347}
348
349sub attach_to_objects {
350 _attach @CB_OBJECT, KLASS_OBJECT, @_
351}
352
353sub attach_to_players {
354 _attach @CB_PLAYER, KLASS_PLAYER, @_
355}
356
357sub attach_to_maps {
358 _attach @CB_MAP, KLASS_MAP, @_
359}
360
361sub register_attachment {
362 my $name = shift;
363
364 $attachment{$name} = [[KLASS_OBJECT, @_]];
365}
366
367sub register_player_attachment {
368 my $name = shift;
369
370 $attachment{$name} = [[KLASS_PLAYER, @_]];
371}
372
373sub register_map_attachment {
374 my $name = shift;
375
376 $attachment{$name} = [[KLASS_MAP, @_]];
377}
378
379our $override;
380our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
381
382sub override {
383 $override = 1;
384 @invoke_results = ();
385}
386
387sub do_invoke {
388 my $event = shift;
389 my $callbacks = shift;
390
391 @invoke_results = ();
392
393 local $override;
394
395 for (@$callbacks) {
396 eval { &{$_->[1]} };
397
398 if ($@) {
399 warn "$@";
400 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
401 override;
402 }
403
404 return 1 if $override;
405 }
406
407 0 559 }
408}
409 560
410=item $bool = cf::invoke EVENT_GLOBAL_XXX, ... 561=item $attachable->valid
411
412=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
413
414=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
415
416=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
417
418Generate a global/object/player/map-specific event with the given arguments.
419
420This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
421removed in future versions), and there is no public API to access override
422results (if you must, access C<@cf::invoke_results> directly).
423
424=back
425
426#############################################################################
427
428=head2 METHODS VALID FOR ALL CORE OBJECTS
429
430=over 4
431
432=item $object->valid, $player->valid, $map->valid
433 562
434Just because you have a perl object does not mean that the corresponding 563Just because you have a perl object does not mean that the corresponding
435C-level object still exists. If you try to access an object that has no 564C-level object still exists. If you try to access an object that has no
436valid C counterpart anymore you get an exception at runtime. This method 565valid C counterpart anymore you get an exception at runtime. This method
437can be used to test for existence of the C object part without causing an 566can be used to test for existence of the C object part without causing an
438exception. 567exception.
439 568
569=cut
570
571# the following variables are defined in .xs and must not be re-created
572our @CB_GLOBAL = (); # registry for all global events
573our @CB_ATTACHABLE = (); # registry for all attachables
574our @CB_OBJECT = (); # all objects (should not be used except in emergency)
575our @CB_PLAYER = ();
576our @CB_CLIENT = ();
577our @CB_TYPE = (); # registry for type (cf-object class) based events
578our @CB_MAP = ();
579
580my %attachment;
581
582sub cf::attachable::thawer_merge {
583 # simply override everything except _meta
584 local $_[0]{_meta};
585 %{$_[0]} = %{$_[1]};
586}
587
588sub _attach_cb($$$$) {
589 my ($registry, $event, $prio, $cb) = @_;
590
591 use sort 'stable';
592
593 $cb = [$prio, $cb];
594
595 @{$registry->[$event]} = sort
596 { $a->[0] cmp $b->[0] }
597 @{$registry->[$event] || []}, $cb;
598}
599
600# hack
601my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
602
603# attach handles attaching event callbacks
604# the only thing the caller has to do is pass the correct
605# registry (== where the callback attaches to).
606sub _attach {
607 my ($registry, $klass, @arg) = @_;
608
609 my $object_type;
610 my $prio = 0;
611 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
612
613 #TODO: get rid of this hack
614 if ($attachable_klass{$klass}) {
615 %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
616 }
617
618 while (@arg) {
619 my $type = shift @arg;
620
621 if ($type eq "prio") {
622 $prio = shift @arg;
623
624 } elsif ($type eq "type") {
625 $object_type = shift @arg;
626 $registry = $CB_TYPE[$object_type] ||= [];
627
628 } elsif ($type eq "subtype") {
629 defined $object_type or Carp::croak "subtype specified without type";
630 my $object_subtype = shift @arg;
631 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
632
633 } elsif ($type eq "package") {
634 my $pkg = shift @arg;
635
636 while (my ($name, $id) = each %cb_id) {
637 if (my $cb = $pkg->can ($name)) {
638 _attach_cb $registry, $id, $prio, $cb;
639 }
640 }
641
642 } elsif (exists $cb_id{$type}) {
643 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
644
645 } elsif (ref $type) {
646 warn "attaching objects not supported, ignoring.\n";
647
648 } else {
649 shift @arg;
650 warn "attach argument '$type' not supported, ignoring.\n";
651 }
652 }
653}
654
655sub _object_attach {
656 my ($obj, $name, %arg) = @_;
657
658 return if exists $obj->{_attachment}{$name};
659
660 if (my $attach = $attachment{$name}) {
661 my $registry = $obj->registry;
662
663 for (@$attach) {
664 my ($klass, @attach) = @$_;
665 _attach $registry, $klass, @attach;
666 }
667
668 $obj->{$name} = \%arg;
669 } else {
670 warn "object uses attachment '$name' that is not available, postponing.\n";
671 }
672
673 $obj->{_attachment}{$name} = undef;
674}
675
676sub cf::attachable::attach {
677 if (ref $_[0]) {
678 _object_attach @_;
679 } else {
680 _attach shift->_attach_registry, @_;
681 }
682 _recalc_want;
683};
684
685# all those should be optimised
686sub cf::attachable::detach {
687 my ($obj, $name) = @_;
688
689 if (ref $obj) {
690 delete $obj->{_attachment}{$name};
691 reattach ($obj);
692 } else {
693 Carp::croak "cannot, currently, detach class attachments";
694 }
695 _recalc_want;
696};
697
698sub cf::attachable::attached {
699 my ($obj, $name) = @_;
700
701 exists $obj->{_attachment}{$name}
702}
703
704for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
705 eval "#line " . __LINE__ . " 'cf.pm'
706 sub cf::\L$klass\E::_attach_registry {
707 (\\\@CB_$klass, KLASS_$klass)
708 }
709
710 sub cf::\L$klass\E::attachment {
711 my \$name = shift;
712
713 \$attachment{\$name} = [[KLASS_$klass, \@_]];
714 }
715 ";
716 die if $@;
717}
718
719our $override;
720our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
721
722sub override {
723 $override = 1;
724 @invoke_results = ();
725}
726
727sub do_invoke {
728 my $event = shift;
729 my $callbacks = shift;
730
731 @invoke_results = ();
732
733 local $override;
734
735 for (@$callbacks) {
736 eval { &{$_->[1]} };
737
738 if ($@) {
739 warn "$@";
740 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
741 override;
742 }
743
744 return 1 if $override;
745 }
746
747 0
748}
749
750=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)
751
752=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
753
754Generate an object-specific event with the given arguments.
755
756This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
757removed in future versions), and there is no public API to access override
758results (if you must, access C<@cf::invoke_results> directly).
759
440=back 760=back
441 761
442=cut 762=cut
443
444*cf::object::valid =
445*cf::player::valid =
446*cf::map::valid = \&cf::_valid;
447 763
448############################################################################# 764#############################################################################
449# object support 765# object support
450 766
451sub instantiate {
452 my ($obj, $data) = @_;
453
454 $data = from_json $data;
455
456 for (@$data) {
457 my ($name, $args) = @$_;
458
459 $obj->attach ($name, %{$args || {} });
460 }
461}
462
463# basically do the same as instantiate, without calling instantiate
464sub reattach { 767sub reattach {
768 # basically do the same as instantiate, without calling instantiate
465 my ($obj) = @_; 769 my ($obj) = @_;
770
771 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
772
466 my $registry = $obj->registry; 773 my $registry = $obj->registry;
467 774
468 @$registry = (); 775 @$registry = ();
469 776
470 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} }; 777 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
471 778
472 for my $name (keys %{ $obj->{_attachment} || {} }) { 779 for my $name (keys %{ $obj->{_attachment} || {} }) {
473 if (my $attach = $attachment{$name}) { 780 if (my $attach = $attachment{$name}) {
474 for (@$attach) { 781 for (@$attach) {
475 my ($klass, @attach) = @$_; 782 my ($klass, @attach) = @$_;
476 _attach @$registry, $klass, @attach; 783 _attach $registry, $klass, @attach;
477 } 784 }
478 } else { 785 } else {
479 warn "object uses attachment '$name' that is not available, postponing.\n"; 786 warn "object uses attachment '$name' that is not available, postponing.\n";
480 } 787 }
481 } 788 }
482} 789}
483 790
484sub object_freezer_save { 791cf::attachable->attach (
485 my ($filename, $rdata, $objs) = @_;
486
487 if (length $$rdata) {
488 warn sprintf "saving %s (%d,%d)\n",
489 $filename, length $$rdata, scalar @$objs;
490
491 if (open my $fh, ">:raw", "$filename~") {
492 chmod SAVE_MODE, $fh;
493 syswrite $fh, $$rdata;
494 close $fh;
495
496 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
497 chmod SAVE_MODE, $fh;
498 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
499 close $fh;
500 rename "$filename.pst~", "$filename.pst";
501 } else {
502 unlink "$filename.pst";
503 }
504
505 rename "$filename~", $filename;
506 } else {
507 warn "FATAL: $filename~: $!\n";
508 }
509 } else {
510 unlink $filename;
511 unlink "$filename.pst";
512 }
513}
514
515sub object_thawer_load {
516 my ($filename) = @_;
517
518 local $/;
519
520 my $av;
521
522 #TODO: use sysread etc.
523 if (open my $data, "<:raw:perlio", $filename) {
524 $data = <$data>;
525 if (open my $pst, "<:raw:perlio", "$filename.pst") {
526 $av = eval { (Storable::thaw <$pst>)->{objs} };
527 }
528 return ($data, $av);
529 }
530
531 ()
532}
533
534attach_to_objects
535 prio => -1000000, 792 prio => -1000000,
793 on_instantiate => sub {
794 my ($obj, $data) = @_;
795
796 $data = from_json $data;
797
798 for (@$data) {
799 my ($name, $args) = @$_;
800
801 $obj->attach ($name, %{$args || {} });
802 }
803 },
804 on_reattach => \&reattach,
536 on_clone => sub { 805 on_clone => sub {
537 my ($src, $dst) = @_; 806 my ($src, $dst) = @_;
538 807
539 @{$dst->registry} = @{$src->registry}; 808 @{$dst->registry} = @{$src->registry};
540 809
541 %$dst = %$src; 810 %$dst = %$src;
542 811
543 %{$dst->{_attachment}} = %{$src->{_attachment}} 812 %{$dst->{_attachment}} = %{$src->{_attachment}}
544 if exists $src->{_attachment}; 813 if exists $src->{_attachment};
545 }, 814 },
546; 815);
816
817sub object_freezer_save {
818 my ($filename, $rdata, $objs) = @_;
819
820 sync_job {
821 if (length $$rdata) {
822 warn sprintf "saving %s (%d,%d)\n",
823 $filename, length $$rdata, scalar @$objs;
824
825 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
826 chmod SAVE_MODE, $fh;
827 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
828 aio_fsync $fh if $cf::USE_FSYNC;
829 close $fh;
830
831 if (@$objs) {
832 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
833 chmod SAVE_MODE, $fh;
834 my $data = Storable::nfreeze { version => 1, objs => $objs };
835 aio_write $fh, 0, (length $data), $data, 0;
836 aio_fsync $fh if $cf::USE_FSYNC;
837 close $fh;
838 aio_rename "$filename.pst~", "$filename.pst";
839 }
840 } else {
841 aio_unlink "$filename.pst";
842 }
843
844 aio_rename "$filename~", $filename;
845 } else {
846 warn "FATAL: $filename~: $!\n";
847 }
848 } else {
849 aio_unlink $filename;
850 aio_unlink "$filename.pst";
851 }
852 }
853}
854
855sub object_freezer_as_string {
856 my ($rdata, $objs) = @_;
857
858 use Data::Dumper;
859
860 $$rdata . Dumper $objs
861}
862
863sub object_thawer_load {
864 my ($filename) = @_;
865
866 my ($data, $av);
867
868 (aio_load $filename, $data) >= 0
869 or return;
870
871 unless (aio_stat "$filename.pst") {
872 (aio_load "$filename.pst", $av) >= 0
873 or return;
874 $av = eval { (Storable::thaw $av)->{objs} };
875 }
876
877 warn sprintf "loading %s (%d)\n",
878 $filename, length $data, scalar @{$av || []};
879 return ($data, $av);
880}
547 881
548############################################################################# 882#############################################################################
549# old plug-in events 883# command handling &c
550 884
551sub inject_event { 885=item cf::register_command $name => \&callback($ob,$args);
552 my $extension = shift;
553 my $event_code = shift;
554 886
555 my $cb = $hook[$event_code]{$extension} 887Register a callback for execution when the client sends the user command
556 or return; 888$name.
557 889
558 &$cb 890=cut
559}
560
561sub inject_global_event {
562 my $event = shift;
563
564 my $cb = $hook[$event]
565 or return;
566
567 List::Util::max map &$_, values %$cb
568}
569
570sub inject_command {
571 my ($name, $obj, $params) = @_;
572
573 for my $cmd (@{ $command{$name} }) {
574 $cmd->[1]->($obj, $params);
575 }
576
577 -1
578}
579 891
580sub register_command { 892sub register_command {
581 my ($name, $time, $cb) = @_; 893 my ($name, $cb) = @_;
582 894
583 my $caller = caller; 895 my $caller = caller;
584 #warn "registering command '$name/$time' to '$caller'"; 896 #warn "registering command '$name/$time' to '$caller'";
585 897
586 push @{ $command{$name} }, [$time, $cb, $caller]; 898 push @{ $COMMAND{$name} }, [$caller, $cb];
587 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
588} 899}
900
901=item cf::register_extcmd $name => \&callback($pl,$packet);
902
903Register a callbackf ro execution when the client sends an extcmd packet.
904
905If the callback returns something, it is sent back as if reply was being
906called.
907
908=cut
589 909
590sub register_extcmd { 910sub register_extcmd {
591 my ($name, $cb) = @_; 911 my ($name, $cb) = @_;
592 912
593 my $caller = caller; 913 $EXTCMD{$name} = $cb;
594 #warn "registering extcmd '$name' to '$caller'";
595
596 $extcmd{$name} = [$cb, $caller];
597} 914}
598 915
599sub register { 916cf::player->attach (
600 my ($base, $pkg) = @_; 917 on_command => sub {
918 my ($pl, $name, $params) = @_;
601 919
602 #TODO 920 my $cb = $COMMAND{$name}
603} 921 or return;
922
923 for my $cmd (@$cb) {
924 $cmd->[1]->($pl->ob, $params);
925 }
926
927 cf::override;
928 },
929 on_extcmd => sub {
930 my ($pl, $buf) = @_;
931
932 my $msg = eval { from_json $buf };
933
934 if (ref $msg) {
935 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
936 if (my %reply = $cb->($pl, $msg)) {
937 $pl->ext_reply ($msg->{msgid}, %reply);
938 }
939 }
940 } else {
941 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
942 }
943
944 cf::override;
945 },
946);
604 947
605sub load_extension { 948sub load_extension {
606 my ($path) = @_; 949 my ($path) = @_;
607 950
608 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 951 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
609 my $base = $1; 952 my $base = $1;
610 my $pkg = $1; 953 my $pkg = $1;
611 $pkg =~ s/[^[:word:]]/_/g; 954 $pkg =~ s/[^[:word:]]/_/g;
612 $pkg = "ext::$pkg"; 955 $pkg = "ext::$pkg";
613 956
614 warn "loading '$path' into '$pkg'\n"; 957 warn "... loading '$path' into '$pkg'\n";
615 958
616 open my $fh, "<:utf8", $path 959 open my $fh, "<:utf8", $path
617 or die "$path: $!"; 960 or die "$path: $!";
618 961
619 my $source = 962 my $source =
620 "package $pkg; use strict; use utf8;\n" 963 "package $pkg; use strict; use utf8;\n"
621 . "#line 1 \"$path\"\n{\n" 964 . "#line 1 \"$path\"\n{\n"
622 . (do { local $/; <$fh> }) 965 . (do { local $/; <$fh> })
623 . "\n};\n1"; 966 . "\n};\n1";
624 967
625 eval $source 968 unless (eval $source) {
626 or die "$path: $@"; 969 my $msg = $@ ? "$path: $@\n"
627 970 : "extension disabled.\n";
628 push @exts, $pkg; 971 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
629 $ext_pkg{$base} = $pkg; 972 warn $@;
630 973 warn "mandatory extension failed to load, exiting.\n";
631# no strict 'refs'; 974 exit 1;
632# @{"$pkg\::ISA"} = ext::; 975 }
633 976 die $@;
634 register $base, $pkg;
635}
636
637sub unload_extension {
638 my ($pkg) = @_;
639
640 warn "removing extension $pkg\n";
641
642 # remove hooks
643 #TODO
644# for my $idx (0 .. $#PLUGIN_EVENT) {
645# delete $hook[$idx]{$pkg};
646# } 977 }
647 978
648 # remove commands 979 push @EXTS, $pkg;
649 for my $name (keys %command) {
650 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
651
652 if (@cb) {
653 $command{$name} = \@cb;
654 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
655 } else {
656 delete $command{$name};
657 delete $COMMAND{"$name\000"};
658 }
659 }
660
661 # remove extcmds
662 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
663 delete $extcmd{$name};
664 }
665
666 if (my $cb = $pkg->can ("unload")) {
667 eval {
668 $cb->($pkg);
669 1
670 } or warn "$pkg unloaded, but with errors: $@";
671 }
672
673 Symbol::delete_package $pkg;
674} 980}
675 981
676sub load_extensions { 982sub load_extensions {
677 my $LIBDIR = maps_directory "perl";
678
679 for my $ext (<$LIBDIR/*.ext>) { 983 for my $ext (<$LIBDIR/*.ext>) {
680 next unless -r $ext; 984 next unless -r $ext;
681 eval { 985 eval {
682 load_extension $ext; 986 load_extension $ext;
683 1 987 1
684 } or warn "$ext not loaded: $@"; 988 } or warn "$ext not loaded: $@";
685 } 989 }
686} 990}
687 991
688############################################################################# 992#############################################################################
689# extcmd framework, basically convert ext <msg>
690# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
691 993
692attach_to_players 994=head2 CORE EXTENSIONS
693 on_extcmd => sub { 995
996Functions and methods that extend core crossfire objects.
997
998=cut
999
1000package cf::player;
1001
1002use Coro::AIO;
1003
1004=head3 cf::player
1005
1006=over 4
1007
1008=item cf::player::find $login
1009
1010Returns the given player object, loading it if necessary (might block).
1011
1012=cut
1013
1014sub playerdir($) {
1015 "$PLAYERDIR/"
1016 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1017}
1018
1019sub path($) {
1020 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1021
1022 (playerdir $login) . "/playerdata"
1023}
1024
1025sub find_active($) {
1026 $cf::PLAYER{$_[0]}
1027 and $cf::PLAYER{$_[0]}->active
1028 and $cf::PLAYER{$_[0]}
1029}
1030
1031sub exists($) {
1032 my ($login) = @_;
1033
1034 $cf::PLAYER{$login}
1035 or cf::sync_job { !aio_stat path $login }
1036}
1037
1038sub find($) {
1039 return $cf::PLAYER{$_[0]} || do {
1040 my $login = $_[0];
1041
1042 my $guard = cf::lock_acquire "user_find:$login";
1043
1044 $cf::PLAYER{$_[0]} || do {
1045 # rename old playerfiles to new ones
1046 #TODO: remove when no longer required
1047 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1048 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1049 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1050 aio_unlink +(playerdir $login) . "/$login.pl";
1051
1052 my $pl = load_pl path $login
1053 or return;
1054 $cf::PLAYER{$login} = $pl
1055 }
1056 }
1057}
1058
1059sub save($) {
694 my ($pl, $buf) = @_; 1060 my ($pl) = @_;
695 1061
696 my $msg = eval { from_json $buf }; 1062 return if $pl->{deny_save};
697 1063
698 if (ref $msg) { 1064 my $path = path $pl;
699 if (my $cb = $extcmd{$msg->{msgtype}}) { 1065 my $guard = cf::lock_acquire "user_save:$path";
700 if (my %reply = $cb->[0]->($pl, $msg)) { 1066
701 $pl->ext_reply ($msg->{msgid}, %reply); 1067 return if $pl->{deny_save};
702 } 1068
1069 aio_mkdir playerdir $pl, 0770;
1070 $pl->{last_save} = $cf::RUNTIME;
1071
1072 $pl->save_pl ($path);
1073 Coro::cede;
1074}
1075
1076sub new($) {
1077 my ($login) = @_;
1078
1079 my $self = create;
1080
1081 $self->ob->name ($login);
1082 $self->{deny_save} = 1;
1083
1084 $cf::PLAYER{$login} = $self;
1085
1086 $self
1087}
1088
1089=item $pl->quit_character
1090
1091Nukes the player without looking back. If logged in, the connection will
1092be destroyed. May block for a long time.
1093
1094=cut
1095
1096sub quit_character {
1097 my ($pl) = @_;
1098
1099 my $name = $pl->ob->name;
1100
1101 $pl->{deny_save} = 1;
1102 $pl->password ("*"); # this should lock out the player until we nuked the dir
1103
1104 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1105 $pl->deactivate;
1106 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1107 $pl->ns->destroy if $pl->ns;
1108
1109 my $path = playerdir $pl;
1110 my $temp = "$path~$cf::RUNTIME~deleting~";
1111 aio_rename $path, $temp;
1112 delete $cf::PLAYER{$pl->ob->name};
1113 $pl->destroy;
1114
1115 my $prefix = qr<^~\Q$name\E/>;
1116
1117 # nuke player maps
1118 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1119
1120 IO::AIO::aio_rmtree $temp;
1121}
1122
1123=item $pl->kick
1124
1125Kicks a player out of the game. This destroys the connection.
1126
1127=cut
1128
1129sub kick {
1130 my ($pl, $kicker) = @_;
1131
1132 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1133 $pl->killer ("kicked");
1134 $pl->ns->destroy;
1135}
1136
1137=item cf::player::list_logins
1138
1139Returns am arrayref of all valid playernames in the system, can take a
1140while and may block, so not sync_job-capable, ever.
1141
1142=cut
1143
1144sub list_logins {
1145 my $dirs = aio_readdir $PLAYERDIR
1146 or return [];
1147
1148 my @logins;
1149
1150 for my $login (@$dirs) {
1151 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1152 aio_read $fh, 0, 512, my $buf, 0 or next;
1153 $buf !~ /^password -------------$/m or next; # official not-valid tag
1154
1155 utf8::decode $login;
1156 push @logins, $login;
1157 }
1158
1159 \@logins
1160}
1161
1162=item $player->maps
1163
1164Returns an arrayref of map paths that are private for this
1165player. May block.
1166
1167=cut
1168
1169sub maps($) {
1170 my ($pl) = @_;
1171
1172 $pl = ref $pl ? $pl->ob->name : $pl;
1173
1174 my $files = aio_readdir playerdir $pl
1175 or return;
1176
1177 my @paths;
1178
1179 for (@$files) {
1180 utf8::decode $_;
1181 next if /\.(?:pl|pst)$/;
1182 next unless /^$PATH_SEP/o;
1183
1184 push @paths, cf::map::normalise "~$pl/$_";
1185 }
1186
1187 \@paths
1188}
1189
1190=item $player->ext_reply ($msgid, %msg)
1191
1192Sends an ext reply to the player.
1193
1194=cut
1195
1196sub ext_reply($$%) {
1197 my ($self, $id, %msg) = @_;
1198
1199 $msg{msgid} = $id;
1200
1201 $self->send ("ext " . cf::to_json \%msg);
1202}
1203
1204=item $player->ext_event ($type, %msg)
1205
1206Sends an ext event to the client.
1207
1208=cut
1209
1210sub ext_event($$%) {
1211 my ($self, $type, %msg) = @_;
1212
1213 $self->ns->ext_event ($type, %msg);
1214}
1215
1216=head3 cf::region
1217
1218=over 4
1219
1220=cut
1221
1222package cf::region;
1223
1224=item cf::region::find_by_path $path
1225
1226Tries to decuce the probable region for a map knowing only its path.
1227
1228=cut
1229
1230sub find_by_path($) {
1231 my ($path) = @_;
1232
1233 my ($match, $specificity);
1234
1235 for my $region (list) {
1236 if ($region->match && $path =~ $region->match) {
1237 ($match, $specificity) = ($region, $region->specificity)
1238 if $region->specificity > $specificity;
1239 }
1240 }
1241
1242 $match
1243}
1244
1245=back
1246
1247=head3 cf::map
1248
1249=over 4
1250
1251=cut
1252
1253package cf::map;
1254
1255use Fcntl;
1256use Coro::AIO;
1257
1258use overload
1259 '""' => \&as_string,
1260 fallback => 1;
1261
1262our $MAX_RESET = 3600;
1263our $DEFAULT_RESET = 3000;
1264
1265sub generate_random_map {
1266 my ($self, $rmp) = @_;
1267 # mit "rum" bekleckern, nicht
1268 $self->_create_random_map (
1269 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1270 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1271 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1272 $rmp->{exit_on_final_map},
1273 $rmp->{xsize}, $rmp->{ysize},
1274 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1275 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1276 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1277 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1278 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1279 (cf::region::find $rmp->{region}), $rmp->{custom}
1280 )
1281}
1282
1283=item cf::map->register ($regex, $prio)
1284
1285Register a handler for the map path matching the given regex at the
1286givne priority (higher is better, built-in handlers have priority 0, the
1287default).
1288
1289=cut
1290
1291sub register {
1292 my (undef, $regex, $prio) = @_;
1293 my $pkg = caller;
1294
1295 no strict;
1296 push @{"$pkg\::ISA"}, __PACKAGE__;
1297
1298 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1299}
1300
1301# also paths starting with '/'
1302$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1303
1304sub thawer_merge {
1305 my ($self, $merge) = @_;
1306
1307 # we have to keep some variables in memory intact
1308 local $self->{path};
1309 local $self->{load_path};
1310
1311 $self->SUPER::thawer_merge ($merge);
1312}
1313
1314sub normalise {
1315 my ($path, $base) = @_;
1316
1317 $path = "$path"; # make sure its a string
1318
1319 $path =~ s/\.map$//;
1320
1321 # map plan:
1322 #
1323 # /! non-realised random map exit (special hack!)
1324 # {... are special paths that are not being touched
1325 # ?xxx/... are special absolute paths
1326 # ?random/... random maps
1327 # /... normal maps
1328 # ~user/... per-player map of a specific user
1329
1330 $path =~ s/$PATH_SEP/\//go;
1331
1332 # treat it as relative path if it starts with
1333 # something that looks reasonable
1334 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1335 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1336
1337 $base =~ s{[^/]+/?$}{};
1338 $path = "$base/$path";
1339 }
1340
1341 for ($path) {
1342 redo if s{//}{/};
1343 redo if s{/\.?/}{/};
1344 redo if s{/[^/]+/\.\./}{/};
1345 }
1346
1347 $path
1348}
1349
1350sub new_from_path {
1351 my (undef, $path, $base) = @_;
1352
1353 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1354
1355 $path = normalise $path, $base;
1356
1357 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1358 if ($path =~ $EXT_MAP{$pkg}[1]) {
1359 my $self = bless cf::map::new, $pkg;
1360 $self->{path} = $path; $self->path ($path);
1361 $self->init; # pass $1 etc.
1362 return $self;
1363 }
1364 }
1365
1366 Carp::carp "unable to resolve path '$path' (base '$base').";
1367 ()
1368}
1369
1370sub init {
1371 my ($self) = @_;
1372
1373 $self
1374}
1375
1376sub as_string {
1377 my ($self) = @_;
1378
1379 "$self->{path}"
1380}
1381
1382# the displayed name, this is a one way mapping
1383sub visible_name {
1384 &as_string
1385}
1386
1387# the original (read-only) location
1388sub load_path {
1389 my ($self) = @_;
1390
1391 "$MAPDIR/$self->{path}.map"
1392}
1393
1394# the temporary/swap location
1395sub save_path {
1396 my ($self) = @_;
1397
1398 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1399 "$TMPDIR/$path.map"
1400}
1401
1402# the unique path, undef == no special unique path
1403sub uniq_path {
1404 my ($self) = @_;
1405
1406 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1407 "$UNIQUEDIR/$path"
1408}
1409
1410# and all this just because we cannot iterate over
1411# all maps in C++...
1412sub change_all_map_light {
1413 my ($change) = @_;
1414
1415 $_->change_map_light ($change)
1416 for grep $_->outdoor, values %cf::MAP;
1417}
1418
1419sub decay_objects {
1420 my ($self) = @_;
1421
1422 return if $self->{deny_reset};
1423
1424 $self->do_decay_objects;
1425}
1426
1427sub unlink_save {
1428 my ($self) = @_;
1429
1430 utf8::encode (my $save = $self->save_path);
1431 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1432 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1433}
1434
1435sub load_header_from($) {
1436 my ($self, $path) = @_;
1437
1438 utf8::encode $path;
1439 #aio_open $path, O_RDONLY, 0
1440 # or return;
1441
1442 $self->_load_header ($path)
1443 or return;
1444
1445 $self->{load_path} = $path;
1446
1447 1
1448}
1449
1450sub load_header_orig {
1451 my ($self) = @_;
1452
1453 $self->load_header_from ($self->load_path)
1454}
1455
1456sub load_header_temp {
1457 my ($self) = @_;
1458
1459 $self->load_header_from ($self->save_path)
1460}
1461
1462sub prepare_temp {
1463 my ($self) = @_;
1464
1465 $self->last_access ((delete $self->{last_access})
1466 || $cf::RUNTIME); #d#
1467 # safety
1468 $self->{instantiate_time} = $cf::RUNTIME
1469 if $self->{instantiate_time} > $cf::RUNTIME;
1470}
1471
1472sub prepare_orig {
1473 my ($self) = @_;
1474
1475 $self->{load_original} = 1;
1476 $self->{instantiate_time} = $cf::RUNTIME;
1477 $self->last_access ($cf::RUNTIME);
1478 $self->instantiate;
1479}
1480
1481sub load_header {
1482 my ($self) = @_;
1483
1484 if ($self->load_header_temp) {
1485 $self->prepare_temp;
1486 } else {
1487 $self->load_header_orig
1488 or return;
1489 $self->prepare_orig;
1490 }
1491
1492 $self->{deny_reset} = 1
1493 if $self->no_reset;
1494
1495 $self->default_region (cf::region::find_by_path $self->{path})
1496 unless $self->default_region;
1497
1498 1
1499}
1500
1501sub find;
1502sub find {
1503 my ($path, $origin) = @_;
1504
1505 $path = normalise $path, $origin && $origin->path;
1506
1507 cf::lock_wait "map_find:$path";
1508
1509 $cf::MAP{$path} || do {
1510 my $guard = cf::lock_acquire "map_find:$path";
1511 my $map = new_from_path cf::map $path
1512 or return;
1513
1514 $map->{last_save} = $cf::RUNTIME;
1515
1516 $map->load_header
1517 or return;
1518
1519 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1520 # doing this can freeze the server in a sync job, obviously
1521 #$cf::WAIT_FOR_TICK->wait;
1522 $map->reset;
1523 undef $guard;
1524 return find $path;
1525 }
1526
1527 $cf::MAP{$path} = $map
1528 }
1529}
1530
1531sub pre_load { }
1532sub post_load { }
1533
1534sub load {
1535 my ($self) = @_;
1536
1537 local $self->{deny_reset} = 1; # loading can take a long time
1538
1539 my $path = $self->{path};
1540
1541 {
1542 my $guard = cf::lock_acquire "map_load:$path";
1543
1544 return if $self->in_memory != cf::MAP_SWAPPED;
1545
1546 $self->in_memory (cf::MAP_LOADING);
1547
1548 $self->alloc;
1549
1550 $self->pre_load;
1551 Coro::cede;
1552
1553 $self->_load_objects ($self->{load_path}, 1)
1554 or return;
1555
1556 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1557 if delete $self->{load_original};
1558
1559 if (my $uniq = $self->uniq_path) {
1560 utf8::encode $uniq;
1561 if (aio_open $uniq, O_RDONLY, 0) {
1562 $self->clear_unique_items;
1563 $self->_load_objects ($uniq, 0);
703 } 1564 }
704 } else {
705 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
706 } 1565 }
707 1566
708 cf::override; 1567 Coro::cede;
1568 # now do the right thing for maps
1569 $self->link_multipart_objects;
1570 $self->difficulty ($self->estimate_difficulty)
1571 unless $self->difficulty;
1572 Coro::cede;
1573
1574 unless ($self->{deny_activate}) {
1575 $self->decay_objects;
1576 $self->fix_auto_apply;
1577 $self->update_buttons;
1578 Coro::cede;
1579 $self->set_darkness_map;
1580 Coro::cede;
1581 $self->activate;
1582 }
1583
1584 $self->in_memory (cf::MAP_IN_MEMORY);
709 }, 1585 }
710;
711 1586
712############################################################################# 1587 $self->post_load;
713# load/save/clean perl data associated with a map 1588}
714 1589
715*cf::mapsupport::on_clean = sub { 1590sub customise_for {
1591 my ($self, $ob) = @_;
1592
1593 return find "~" . $ob->name . "/" . $self->{path}
1594 if $self->per_player;
1595
1596# return find "?party/" . $ob->name . "/" . $self->{path}
1597# if $self->per_party;
1598
1599 $self
1600}
1601
1602# find and load all maps in the 3x3 area around a map
1603sub load_diag {
716 my ($map) = @_; 1604 my ($map) = @_;
717 1605
718 my $path = $map->tmpname; 1606 my @diag; # diagonal neighbours
719 defined $path or return;
720 1607
721 unlink "$path.pst"; 1608 for (0 .. 3) {
722}; 1609 my $neigh = $map->tile_path ($_)
1610 or next;
1611 $neigh = find $neigh, $map
1612 or next;
1613 $neigh->load;
723 1614
724attach_to_maps prio => -10000, package => cf::mapsupport::; 1615 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1616 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1617 }
725 1618
726############################################################################# 1619 for (@diag) {
727# load/save perl data associated with player->ob objects 1620 my $neigh = find @$_
728 1621 or next;
729sub all_objects(@) { 1622 $neigh->load;
730 @_, map all_objects ($_->inv), @_ 1623 }
731} 1624}
732 1625
733# TODO: compatibility cruft, remove when no longer needed 1626sub find_sync {
734attach_to_players 1627 my ($path, $origin) = @_;
735 on_load => sub {
736 my ($pl, $path) = @_;
737 1628
738 for my $o (all_objects $pl->ob) { 1629 cf::sync_job { find $path, $origin }
739 if (my $value = $o->get_ob_key_value ("_perl_data")) { 1630}
740 $o->set_ob_key_value ("_perl_data");
741 1631
742 %$o = %{ Storable::thaw pack "H*", $value }; 1632sub do_load_sync {
1633 my ($map) = @_;
1634
1635 cf::sync_job { $map->load };
1636}
1637
1638our %MAP_PREFETCH;
1639our $MAP_PREFETCHER = undef;
1640
1641sub find_async {
1642 my ($path, $origin) = @_;
1643
1644 $path = normalise $path, $origin && $origin->{path};
1645
1646 if (my $map = $cf::MAP{$path}) {
1647 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1648 }
1649
1650 undef $MAP_PREFETCH{$path};
1651 $MAP_PREFETCHER ||= cf::async {
1652 while (%MAP_PREFETCH) {
1653 for my $path (keys %MAP_PREFETCH) {
1654 my $map = find $path
1655 or next;
1656 $map->load;
1657
1658 delete $MAP_PREFETCH{$path};
743 } 1659 }
744 } 1660 }
1661 undef $MAP_PREFETCHER;
1662 };
1663 $MAP_PREFETCHER->prio (6);
1664
1665 ()
1666}
1667
1668sub save {
1669 my ($self) = @_;
1670
1671 my $lock = cf::lock_acquire "map_data:" . $self->path;
1672
1673 $self->{last_save} = $cf::RUNTIME;
1674
1675 return unless $self->dirty;
1676
1677 my $save = $self->save_path; utf8::encode $save;
1678 my $uniq = $self->uniq_path; utf8::encode $uniq;
1679
1680 $self->{load_path} = $save;
1681
1682 return if $self->{deny_save};
1683
1684 local $self->{last_access} = $self->last_access;#d#
1685
1686 cf::async {
1687 $_->contr->save for $self->players;
1688 };
1689
1690 if ($uniq) {
1691 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1692 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1693 } else {
1694 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
745 }, 1695 }
746; 1696}
747 1697
748############################################################################# 1698sub swap_out {
1699 my ($self) = @_;
749 1700
750=head2 CORE EXTENSIONS 1701 # save first because save cedes
1702 $self->save;
751 1703
752Functions and methods that extend core crossfire objects. 1704 my $lock = cf::lock_acquire "map_data:" . $self->path;
1705
1706 return if $self->players;
1707 return if $self->in_memory != cf::MAP_IN_MEMORY;
1708 return if $self->{deny_save};
1709
1710 $self->clear;
1711 $self->in_memory (cf::MAP_SWAPPED);
1712}
1713
1714sub reset_at {
1715 my ($self) = @_;
1716
1717 # TODO: safety, remove and allow resettable per-player maps
1718 return 1e99 if $self->{deny_reset};
1719
1720 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1721 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1722
1723 $time + $to
1724}
1725
1726sub should_reset {
1727 my ($self) = @_;
1728
1729 $self->reset_at <= $cf::RUNTIME
1730}
1731
1732sub reset {
1733 my ($self) = @_;
1734
1735 my $lock = cf::lock_acquire "map_data:$self->{path}";
1736
1737 return if $self->players;
1738
1739 warn "resetting map ", $self->path;
1740
1741 $self->in_memory (cf::MAP_SWAPPED);
1742
1743 # need to save uniques path
1744 unless ($self->{deny_save}) {
1745 my $uniq = $self->uniq_path; utf8::encode $uniq;
1746
1747 $self->_save_objects ($uniq, cf::IO_UNIQUES)
1748 if $uniq;
1749 }
1750
1751 delete $cf::MAP{$self->path};
1752
1753 $self->clear;
1754
1755 $_->clear_links_to ($self) for values %cf::MAP;
1756
1757 $self->unlink_save;
1758 $self->destroy;
1759}
1760
1761my $nuke_counter = "aaaa";
1762
1763sub nuke {
1764 my ($self) = @_;
1765
1766 delete $cf::MAP{$self->path};
1767
1768 $self->unlink_save;
1769
1770 bless $self, "cf::map";
1771 delete $self->{deny_reset};
1772 $self->{deny_save} = 1;
1773 $self->reset_timeout (1);
1774 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1775
1776 $cf::MAP{$self->path} = $self;
1777
1778 $self->reset; # polite request, might not happen
1779}
1780
1781=item $maps = cf::map::tmp_maps
1782
1783Returns an arrayref with all map paths of currently instantiated and saved
1784maps.
1785
1786=cut
1787
1788sub tmp_maps() {
1789 [
1790 map {
1791 utf8::decode $_;
1792 !/\.(?:pst|meta)$/ && /^$PATH_SEP/o
1793 ? normalise $_
1794 : ()
1795 } @{ aio_readdir $TMPDIR or [] }
1796 ]
1797}
1798
1799=item cf::map::unique_maps
1800
1801Returns an arrayref of paths of all shared maps that have
1802instantiated unique items. May block.
1803
1804=cut
1805
1806sub unique_maps() {
1807 [
1808 map {
1809 utf8::decode $_;
1810 !/\.(?:pst|meta)$/ && /^$PATH_SEP/o
1811 ? normalise $_
1812 : ()
1813 } @{ aio_readdir $UNIQUEDIR or [] }
1814 ]
1815}
1816
1817package cf;
1818
1819=back
1820
1821=head3 cf::object
1822
1823=cut
1824
1825package cf::object;
753 1826
754=over 4 1827=over 4
755 1828
756=item cf::player::exists $login 1829=item $ob->inv_recursive
757 1830
758Returns true when the given account exists. 1831Returns the inventory of the object _and_ their inventories, recursively.
759 1832
760=cut 1833=cut
761 1834
762sub cf::player::exists($) { 1835sub inv_recursive_;
763 cf::player::find $_[0] 1836sub inv_recursive_ {
764 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 1837 map { $_, inv_recursive_ $_->inv } @_
765} 1838}
766 1839
1840sub inv_recursive {
1841 inv_recursive_ inv $_[0]
1842}
1843
1844package cf;
1845
1846=back
1847
1848=head3 cf::object::player
1849
1850=over 4
1851
767=item $player->reply ($npc, $msg[, $flags]) 1852=item $player_object->reply ($npc, $msg[, $flags])
768 1853
769Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 1854Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
770can be C<undef>. Does the right thing when the player is currently in a 1855can be C<undef>. Does the right thing when the player is currently in a
771dialogue with the given NPC character. 1856dialogue with the given NPC character.
772 1857
773=cut 1858=cut
774 1859
775# rough implementation of a future "reply" method that works 1860# rough implementation of a future "reply" method that works
776# with dialog boxes. 1861# with dialog boxes.
1862#TODO: the first argument must go, split into a $npc->reply_to ( method
777sub cf::object::player::reply($$$;$) { 1863sub cf::object::player::reply($$$;$) {
778 my ($self, $npc, $msg, $flags) = @_; 1864 my ($self, $npc, $msg, $flags) = @_;
779 1865
780 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 1866 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
781 1867
785 $msg = $npc->name . " says: $msg" if $npc; 1871 $msg = $npc->name . " says: $msg" if $npc;
786 $self->message ($msg, $flags); 1872 $self->message ($msg, $flags);
787 } 1873 }
788} 1874}
789 1875
790=item $player->ext_reply ($msgid, $msgtype, %msg) 1876=item $player_object->may ("access")
791 1877
792Sends an ext reply to the player. 1878Returns wether the given player is authorized to access resource "access"
1879(e.g. "command_wizcast").
793 1880
794=cut 1881=cut
795 1882
796sub cf::player::ext_reply($$$%) { 1883sub cf::object::player::may {
1884 my ($self, $access) = @_;
1885
1886 $self->flag (cf::FLAG_WIZ) ||
1887 (ref $cf::CFG{"may_$access"}
1888 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
1889 : $cf::CFG{"may_$access"})
1890}
1891
1892=item $player_object->enter_link
1893
1894Freezes the player and moves him/her to a special map (C<{link}>).
1895
1896The player should be reasonably safe there for short amounts of time. You
1897I<MUST> call C<leave_link> as soon as possible, though.
1898
1899Will never block.
1900
1901=item $player_object->leave_link ($map, $x, $y)
1902
1903Moves the player out of the special C<{link}> map onto the specified
1904map. If the map is not valid (or omitted), the player will be moved back
1905to the location he/she was before the call to C<enter_link>, or, if that
1906fails, to the emergency map position.
1907
1908Might block.
1909
1910=cut
1911
1912sub link_map {
1913 unless ($LINK_MAP) {
1914 $LINK_MAP = cf::map::find "{link}"
1915 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1916 $LINK_MAP->load;
1917 }
1918
1919 $LINK_MAP
1920}
1921
1922sub cf::object::player::enter_link {
1923 my ($self) = @_;
1924
1925 $self->deactivate_recursive;
1926
1927 return if UNIVERSAL::isa $self->map, "ext::map_link";
1928
1929 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1930 if $self->map && $self->map->{path} ne "{link}";
1931
1932 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1933}
1934
1935sub cf::object::player::leave_link {
1936 my ($self, $map, $x, $y) = @_;
1937
1938 return unless $self->contr->active;
1939
1940 my $link_pos = delete $self->{_link_pos};
1941
1942 unless ($map) {
1943 # restore original map position
1944 ($map, $x, $y) = @{ $link_pos || [] };
1945 $map = cf::map::find $map;
1946
1947 unless ($map) {
1948 ($map, $x, $y) = @$EMERGENCY_POSITION;
1949 $map = cf::map::find $map
1950 or die "FATAL: cannot load emergency map\n";
1951 }
1952 }
1953
1954 ($x, $y) = (-1, -1)
1955 unless (defined $x) && (defined $y);
1956
1957 # use -1 or undef as default coordinates, not 0, 0
1958 ($x, $y) = ($map->enter_x, $map->enter_y)
1959 if $x <=0 && $y <= 0;
1960
1961 $map->load;
1962 $map->load_diag;
1963
1964 return unless $self->contr->active;
1965 $self->activate_recursive;
1966
1967 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1968 $self->enter_map ($map, $x, $y);
1969}
1970
1971=item $player_object->goto ($path, $x, $y[, $check->($map)])
1972
1973Moves the player to the given map-path and coordinates by first freezing
1974her, loading and preparing them map, calling the provided $check callback
1975that has to return the map if sucecssful, and then unfreezes the player on
1976the new (success) or old (failed) map position.
1977
1978=cut
1979
1980our $GOTOGEN;
1981
1982sub cf::object::player::goto {
1983 my ($self, $path, $x, $y, $check) = @_;
1984
1985 # do generation counting so two concurrent goto's will be executed in-order
1986 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1987
1988 $self->enter_link;
1989
1990 (async {
1991 my $map = eval {
1992 my $map = cf::map::find $path;
1993
1994 if ($map) {
1995 $map = $map->customise_for ($self);
1996 $map = $check->($map) if $check && $map;
1997 } else {
1998 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1999 }
2000
2001 $map
2002 };
2003
2004 if ($@) {
2005 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2006 LOG llevError | logBacktrace, Carp::longmess $@;
2007 }
2008
2009 if ($gen == $self->{_goto_generation}) {
2010 delete $self->{_goto_generation};
2011 $self->leave_link ($map, $x, $y);
2012 }
2013 })->prio (1);
2014}
2015
2016=item $player_object->enter_exit ($exit_object)
2017
2018=cut
2019
2020sub parse_random_map_params {
2021 my ($spec) = @_;
2022
2023 my $rmp = { # defaults
2024 xsize => (cf::rndm 15, 40),
2025 ysize => (cf::rndm 15, 40),
2026 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2027 #layout => string,
2028 };
2029
2030 for (split /\n/, $spec) {
2031 my ($k, $v) = split /\s+/, $_, 2;
2032
2033 $rmp->{lc $k} = $v if (length $k) && (length $v);
2034 }
2035
2036 $rmp
2037}
2038
2039sub prepare_random_map {
2040 my ($exit) = @_;
2041
2042 my $guard = cf::lock_acquire "exit_prepare:$exit";
2043
2044 # all this does is basically replace the /! path by
2045 # a new random map path (?random/...) with a seed
2046 # that depends on the exit object
2047
2048 my $rmp = parse_random_map_params $exit->msg;
2049
2050 if ($exit->map) {
2051 $rmp->{region} = $exit->region->name;
2052 $rmp->{origin_map} = $exit->map->path;
2053 $rmp->{origin_x} = $exit->x;
2054 $rmp->{origin_y} = $exit->y;
2055 }
2056
2057 $rmp->{random_seed} ||= $exit->random_seed;
2058
2059 my $data = cf::to_json $rmp;
2060 my $md5 = Digest::MD5::md5_hex $data;
2061 my $meta = "$RANDOMDIR/$md5.meta";
2062
2063 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2064 aio_write $fh, 0, (length $data), $data, 0;
2065 undef $fh;
2066 aio_rename "$meta~", $meta;
2067
2068 $exit->slaying ("?random/$md5");
2069 $exit->msg (undef);
2070 }
2071}
2072
2073sub cf::object::player::enter_exit {
2074 my ($self, $exit) = @_;
2075
2076 return unless $self->type == cf::PLAYER;
2077
2078 if ($exit->slaying eq "/!") {
2079 #TODO: this should de-fi-ni-te-ly not be a sync-job
2080 # the problem is that $exit might not survive long enough
2081 # so it needs to be done right now, right here
2082 cf::sync_job { prepare_random_map $exit };
2083 }
2084
2085 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2086 my $hp = $exit->stats->hp;
2087 my $sp = $exit->stats->sp;
2088
2089 $self->enter_link;
2090
2091 (async {
2092 $self->deactivate_recursive; # just to be sure
2093 unless (eval {
2094 $self->goto ($slaying, $hp, $sp);
2095
2096 1;
2097 }) {
2098 $self->message ("Something went wrong deep within the crossfire server. "
2099 . "I'll try to bring you back to the map you were before. "
2100 . "Please report this to the dungeon master!",
2101 cf::NDI_UNIQUE | cf::NDI_RED);
2102
2103 warn "ERROR in enter_exit: $@";
2104 $self->leave_link;
2105 }
2106 })->prio (1);
2107}
2108
2109=head3 cf::client
2110
2111=over 4
2112
2113=item $client->send_drawinfo ($text, $flags)
2114
2115Sends a drawinfo packet to the client. Circumvents output buffering so
2116should not be used under normal circumstances.
2117
2118=cut
2119
2120sub cf::client::send_drawinfo {
2121 my ($self, $text, $flags) = @_;
2122
2123 utf8::encode $text;
2124 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2125}
2126
2127=item $client->ext_event ($type, %msg)
2128
2129Sends an exti event to the client.
2130
2131=cut
2132
2133sub cf::client::ext_event($$%) {
797 my ($self, $id, %msg) = @_; 2134 my ($self, $type, %msg) = @_;
798 2135
799 $msg{msgid} = $id; 2136 $msg{msgtype} = "event_$type";
800
801 $self->send ("ext " . to_json \%msg); 2137 $self->send_packet ("ext " . cf::to_json \%msg);
802} 2138}
2139
2140=item $success = $client->query ($flags, "text", \&cb)
2141
2142Queues a query to the client, calling the given callback with
2143the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2144C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2145
2146Queries can fail, so check the return code. Or don't, as queries will become
2147reliable at some point in the future.
2148
2149=cut
2150
2151sub cf::client::query {
2152 my ($self, $flags, $text, $cb) = @_;
2153
2154 return unless $self->state == ST_PLAYING
2155 || $self->state == ST_SETUP
2156 || $self->state == ST_CUSTOM;
2157
2158 $self->state (ST_CUSTOM);
2159
2160 utf8::encode $text;
2161 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2162
2163 $self->send_packet ($self->{query_queue}[0][0])
2164 if @{ $self->{query_queue} } == 1;
2165}
2166
2167cf::client->attach (
2168 on_reply => sub {
2169 my ($ns, $msg) = @_;
2170
2171 # this weird shuffling is so that direct followup queries
2172 # get handled first
2173 my $queue = delete $ns->{query_queue}
2174 or return; # be conservative, not sure how that can happen, but we saw a crash here
2175
2176 (shift @$queue)->[1]->($msg);
2177 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
2178
2179 push @{ $ns->{query_queue} }, @$queue;
2180
2181 if (@{ $ns->{query_queue} } == @$queue) {
2182 if (@$queue) {
2183 $ns->send_packet ($ns->{query_queue}[0][0]);
2184 } else {
2185 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2186 }
2187 }
2188 },
2189);
2190
2191=item $client->async (\&cb)
2192
2193Create a new coroutine, running the specified callback. The coroutine will
2194be automatically cancelled when the client gets destroyed (e.g. on logout,
2195or loss of connection).
2196
2197=cut
2198
2199sub cf::client::async {
2200 my ($self, $cb) = @_;
2201
2202 my $coro = &Coro::async ($cb);
2203
2204 $coro->on_destroy (sub {
2205 delete $self->{_coro}{$coro+0};
2206 });
2207
2208 $self->{_coro}{$coro+0} = $coro;
2209
2210 $coro
2211}
2212
2213cf::client->attach (
2214 on_destroy => sub {
2215 my ($ns) = @_;
2216
2217 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2218 },
2219);
803 2220
804=back 2221=back
805 2222
806=cut
807
808#############################################################################
809 2223
810=head2 SAFE SCRIPTING 2224=head2 SAFE SCRIPTING
811 2225
812Functions that provide a safe environment to compile and execute 2226Functions that provide a safe environment to compile and execute
813snippets of perl code without them endangering the safety of the server 2227snippets of perl code without them endangering the safety of the server
814itself. Looping constructs, I/O operators and other built-in functionality 2228itself. Looping constructs, I/O operators and other built-in functionality
815is not available in the safe scripting environment, and the number of 2229is not available in the safe scripting environment, and the number of
816functions and methods that cna be called is greatly reduced. 2230functions and methods that can be called is greatly reduced.
817 2231
818=cut 2232=cut
819 2233
820our $safe = new Safe "safe"; 2234our $safe = new Safe "safe";
821our $safe_hole = new Safe::Hole; 2235our $safe_hole = new Safe::Hole;
826 2240
827# here we export the classes and methods available to script code 2241# here we export the classes and methods available to script code
828 2242
829=pod 2243=pod
830 2244
831The following fucntions and emthods are available within a safe environment: 2245The following functions and methods are available within a safe environment:
832 2246
833 cf::object contr pay_amount pay_player 2247 cf::object contr pay_amount pay_player map
834 cf::object::player player 2248 cf::object::player player
835 cf::player peaceful 2249 cf::player peaceful
2250 cf::map trigger
836 2251
837=cut 2252=cut
838 2253
839for ( 2254for (
840 ["cf::object" => qw(contr pay_amount pay_player)], 2255 ["cf::object" => qw(contr pay_amount pay_player map)],
841 ["cf::object::player" => qw(player)], 2256 ["cf::object::player" => qw(player)],
842 ["cf::player" => qw(peaceful)], 2257 ["cf::player" => qw(peaceful)],
2258 ["cf::map" => qw(trigger)],
843) { 2259) {
844 no strict 'refs'; 2260 no strict 'refs';
845 my ($pkg, @funs) = @$_; 2261 my ($pkg, @funs) = @$_;
846 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 2262 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
847 for @funs; 2263 for @funs;
912 *{"safe::$fun"} = $safe_hole->wrap ($cb); 2328 *{"safe::$fun"} = $safe_hole->wrap ($cb);
913} 2329}
914 2330
915=back 2331=back
916 2332
2333=cut
2334
917############################################################################# 2335#############################################################################
918 2336
919=head2 EXTENSION DATABASE SUPPORT 2337=head2 EXTENSION DATABASE SUPPORT
920 2338
921Crossfire maintains a very simple database for extension use. It can 2339Crossfire maintains a very simple database for extension use. It can
922currently store anything that can be serialised using Storable, which 2340currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
923excludes objects. 2341convert to/from binary).
924 2342
925The parameter C<$family> should best start with the name of the extension 2343The parameter C<$family> should best start with the name of the extension
926using it, it should be unique. 2344using it, it should be unique.
927 2345
928=over 4 2346=over 4
929 2347
930=item $hashref = cf::db_get $family
931
932Return a hashref for use by the extension C<$family>, which can be
933modified. After modifications, you have to call C<cf::db_dirty> or
934C<cf::db_sync>.
935
936=item $value = cf::db_get $family => $key 2348=item $value = cf::db_get $family => $key
937 2349
938Returns a single value from the database 2350Returns a single value from the database.
939
940=item cf::db_put $family => $hashref
941
942Stores the given family hashref into the database. Updates are delayed, if
943you want the data to be synced to disk immediately, use C<cf::db_sync>.
944 2351
945=item cf::db_put $family => $key => $value 2352=item cf::db_put $family => $key => $value
946 2353
947Stores the given C<$value> in the family hash. Updates are delayed, if you 2354Stores the given C<$value> in the family.
948want the data to be synced to disk immediately, use C<cf::db_sync>.
949 2355
950=item cf::db_dirty
951
952Marks the database as dirty, to be updated at a later time.
953
954=item cf::db_sync
955
956Immediately write the database to disk I<if it is dirty>.
957
958=cut 2356=cut
959 2357
960{ 2358our $DB;
961 my $db;
962 my $path = cf::localdir . "/database.pst";
963 2359
964 sub db_load() { 2360sub db_init {
965 warn "loading database $path\n";#d# remove later 2361 unless ($DB) {
966 $db = stat $path ? Storable::retrieve $path : { }; 2362 $DB = BDB::db_create $DB_ENV;
967 }
968 2363
969 my $pid; 2364 cf::sync_job {
2365 eval {
2366 $DB->set_flags (BDB::CHKSUM);
970 2367
971 sub db_save() { 2368 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
972 warn "saving database $path\n";#d# remove later 2369 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
973 waitpid $pid, 0 if $pid; 2370 cf::cleanup "db_open(db): $!" if $!;
974 if (0 == ($pid = fork)) { 2371 };
975 $db->{_meta}{version} = 1; 2372 cf::cleanup "db_open(db): $@" if $@;
976 Storable::nstore $db, "$path~";
977 rename "$path~", $path;
978 cf::_exit 0 if defined $pid;
979 } 2373 };
980 }
981
982 my $dirty;
983
984 sub db_sync() {
985 db_save if $dirty;
986 undef $dirty;
987 }
988
989 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub {
990 db_sync;
991 }); 2374 }
2375}
992 2376
993 sub db_dirty() {
994 $dirty = 1;
995 $idle->start;
996 }
997
998 sub db_get($;$) { 2377sub db_get($$) {
999 @_ >= 2 2378 my $key = "$_[0]/$_[1]";
1000 ? $db->{$_[0]}{$_[1]}
1001 : ($db->{$_[0]} ||= { })
1002 }
1003 2379
2380 cf::sync_job {
2381 BDB::db_get $DB, undef, $key, my $data;
2382
2383 $! ? ()
2384 : $data
2385 }
2386}
2387
1004 sub db_put($$;$) { 2388sub db_put($$$) {
1005 if (@_ >= 3) { 2389 BDB::dbreq_pri 4;
1006 $db->{$_[0]}{$_[1]} = $_[2]; 2390 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
1007 } else { 2391}
1008 $db->{$_[0]} = $_[1];
1009 }
1010 db_dirty;
1011 }
1012 2392
1013 attach_global 2393=item cf::cache $id => [$paths...], $processversion => $process
1014 prio => 10000, 2394
1015 on_cleanup => sub { 2395Generic caching function that returns the value of the resource $id,
1016 db_sync; 2396caching and regenerating as required.
2397
2398This function can block.
2399
2400=cut
2401
2402sub cache {
2403 my ($id, $src, $processversion, $process) = @_;
2404
2405 my $meta =
2406 join "\x00",
2407 $processversion,
2408 map {
2409 aio_stat $_
2410 and Carp::croak "$_: $!";
2411
2412 ($_, (stat _)[7,9])
2413 } @$src;
2414
2415 my $dbmeta = db_get cache => "$id/meta";
2416 if ($dbmeta ne $meta) {
2417 # changed, we may need to process
2418
2419 my @data;
2420 my $md5;
2421
2422 for (0 .. $#$src) {
2423 0 <= aio_load $src->[$_], $data[$_]
2424 or Carp::croak "$src->[$_]: $!";
1017 }, 2425 }
2426
2427 # if processing is expensive, check
2428 # checksum first
2429 if (1) {
2430 $md5 =
2431 join "\x00",
2432 $processversion,
2433 map {
2434 Coro::cede;
2435 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2436 } 0.. $#$src;
2437
2438
2439 my $dbmd5 = db_get cache => "$id/md5";
2440 if ($dbmd5 eq $md5) {
2441 db_put cache => "$id/meta", $meta;
2442
2443 return db_get cache => "$id/data";
2444 }
2445 }
2446
2447 my $t1 = Time::HiRes::time;
2448 my $data = $process->(\@data);
2449 my $t2 = Time::HiRes::time;
2450
2451 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2452
2453 db_put cache => "$id/data", $data;
2454 db_put cache => "$id/md5" , $md5;
2455 db_put cache => "$id/meta", $meta;
2456
2457 return $data;
1018 ; 2458 }
2459
2460 db_get cache => "$id/data"
2461}
2462
2463=item fork_call { }, $args
2464
2465Executes the given code block with the given arguments in a seperate
2466process, returning the results. Everything must be serialisable with
2467Coro::Storable. May, of course, block. Note that the executed sub may
2468never block itself or use any form of Event handling.
2469
2470=cut
2471
2472sub fork_call(&@) {
2473 my ($cb, @args) = @_;
2474
2475# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2476# or die "socketpair: $!";
2477 pipe my $fh1, my $fh2
2478 or die "pipe: $!";
2479
2480 if (my $pid = fork) {
2481 close $fh2;
2482
2483 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2484 $res = Coro::Storable::thaw $res;
2485
2486 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2487
2488 die $$res unless "ARRAY" eq ref $res;
2489
2490 return wantarray ? @$res : $res->[-1];
2491 } else {
2492 reset_signals;
2493 local $SIG{__WARN__};
2494 local $SIG{__DIE__};
2495 eval {
2496 close $fh1;
2497
2498 my @res = eval { $cb->(@args) };
2499 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2500 };
2501
2502 warn $@ if $@;
2503 _exit 0;
2504 }
1019} 2505}
1020 2506
1021############################################################################# 2507#############################################################################
1022# the server's main() 2508# the server's init and main functions
2509
2510sub load_facedata($) {
2511 my ($path) = @_;
2512
2513 warn "loading facedata from $path\n";
2514
2515 my $facedata;
2516 0 < aio_load $path, $facedata
2517 or die "$path: $!";
2518
2519 $facedata = Coro::Storable::thaw $facedata;
2520
2521 $facedata->{version} == 2
2522 or cf::cleanup "$path: version mismatch, cannot proceed.";
2523
2524 {
2525 my $faces = $facedata->{faceinfo};
2526
2527 while (my ($face, $info) = each %$faces) {
2528 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2529 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2530 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2531 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2532 Coro::cede;
2533 }
2534
2535 while (my ($face, $info) = each %$faces) {
2536 next unless $info->{smooth};
2537 my $idx = cf::face::find $face
2538 or next;
2539 if (my $smooth = cf::face::find $info->{smooth}) {
2540 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2541 } else {
2542 warn "smooth face '$info->{smooth}' not found for face '$face'";
2543 }
2544 Coro::cede;
2545 }
2546 }
2547
2548 {
2549 my $anims = $facedata->{animinfo};
2550
2551 while (my ($anim, $info) = each %$anims) {
2552 cf::anim::set $anim, $info->{frames}, $info->{facings};
2553 Coro::cede;
2554 }
2555
2556 cf::anim::invalidate_all; # d'oh
2557 }
2558
2559 1
2560}
2561
2562sub reload_regions {
2563 load_resource_file "$MAPDIR/regions"
2564 or die "unable to load regions file\n";
2565}
2566
2567sub reload_facedata {
2568 load_facedata "$DATADIR/facedata"
2569 or die "unable to load facedata\n";
2570}
2571
2572sub reload_archetypes {
2573 load_resource_file "$DATADIR/archetypes"
2574 or die "unable to load archetypes\n";
2575}
2576
2577sub reload_treasures {
2578 load_resource_file "$DATADIR/treasures"
2579 or die "unable to load treasurelists\n";
2580}
2581
2582sub reload_resources {
2583 warn "reloading resource files...\n";
2584
2585 reload_regions;
2586 reload_facedata;
2587 #reload_archetypes;#d#
2588 reload_archetypes;
2589 reload_treasures;
2590
2591 warn "finished reloading resource files\n";
2592}
2593
2594sub init {
2595 reload_resources;
2596}
2597
2598sub cfg_load {
2599 open my $fh, "<:utf8", "$CONFDIR/config"
2600 or return;
2601
2602 local $/;
2603 *CFG = YAML::Syck::Load <$fh>;
2604
2605 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2606
2607 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2608 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2609
2610 if (exists $CFG{mlockall}) {
2611 eval {
2612 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2613 and die "WARNING: m(un)lockall failed: $!\n";
2614 };
2615 warn $@ if $@;
2616 }
2617}
1023 2618
1024sub main { 2619sub main {
2620 # we must not ever block the main coroutine
2621 local $Coro::idle = sub {
2622 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2623 (async {
2624 Event::one_event;
2625 })->prio (Coro::PRIO_MAX);
2626 };
2627
1025 db_load; 2628 cfg_load;
2629 db_init;
1026 load_extensions; 2630 load_extensions;
2631
2632 $TICK_WATCHER->start;
1027 Event::loop; 2633 Event::loop;
1028} 2634}
1029 2635
1030############################################################################# 2636#############################################################################
1031# initialisation 2637# initialisation and cleanup
1032 2638
1033sub _perl_reload(&) { 2639# install some emergency cleanup handlers
2640BEGIN {
2641 for my $signal (qw(INT HUP TERM)) {
2642 Event->signal (
2643 reentrant => 0,
2644 data => WF_AUTOCANCEL,
2645 signal => $signal,
2646 prio => 0,
2647 cb => sub {
2648 cf::cleanup "SIG$signal";
2649 },
2650 );
2651 }
2652}
2653
2654sub emergency_save() {
2655 my $freeze_guard = cf::freeze_mainloop;
2656
2657 warn "enter emergency perl save\n";
2658
2659 cf::sync_job {
2660 # use a peculiar iteration method to avoid tripping on perl
2661 # refcount bugs in for. also avoids problems with players
2662 # and maps saved/destroyed asynchronously.
2663 warn "begin emergency player save\n";
2664 for my $login (keys %cf::PLAYER) {
2665 my $pl = $cf::PLAYER{$login} or next;
2666 $pl->valid or next;
2667 $pl->save;
2668 }
2669 warn "end emergency player save\n";
2670
2671 warn "begin emergency map save\n";
2672 for my $path (keys %cf::MAP) {
2673 my $map = $cf::MAP{$path} or next;
2674 $map->valid or next;
2675 $map->save;
2676 }
2677 warn "end emergency map save\n";
2678
2679 warn "begin emergency database checkpoint\n";
2680 BDB::db_env_txn_checkpoint $DB_ENV;
2681 warn "end emergency database checkpoint\n";
2682 };
2683
2684 warn "leave emergency perl save\n";
2685}
2686
2687sub post_cleanup {
1034 my ($msg) = @_; 2688 my ($make_core) = @_;
1035 2689
1036 $msg->("reloading..."); 2690 warn Carp::longmess "post_cleanup backtrace"
2691 if $make_core;
2692}
1037 2693
1038 eval { 2694sub do_reload_perl() {
1039 # cancel all watchers 2695 # can/must only be called in main
2696 if ($Coro::current != $Coro::main) {
2697 warn "can only reload from main coroutine";
2698 return;
2699 }
2700
2701 warn "reloading...";
2702
2703 warn "entering sync_job";
2704
2705 cf::sync_job {
2706 cf::write_runtime; # external watchdog should not bark
2707 cf::emergency_save;
2708 cf::write_runtime; # external watchdog should not bark
2709
2710 warn "syncing database to disk";
2711 BDB::db_env_txn_checkpoint $DB_ENV;
2712
2713 # if anything goes wrong in here, we should simply crash as we already saved
2714
2715 warn "cancelling all WF_AUTOCANCEL watchers";
1040 $_->cancel for Event::all_watchers; 2716 for (Event::all_watchers) {
2717 $_->cancel if $_->data & WF_AUTOCANCEL;
2718 }
1041 2719
1042 # unload all extensions 2720 warn "flushing outstanding aio requests";
1043 for (@exts) { 2721 for (;;) {
1044 $msg->("unloading <$_>"); 2722 BDB::flush;
1045 unload_extension $_; 2723 IO::AIO::flush;
2724 Coro::cede;
2725 last unless IO::AIO::nreqs || BDB::nreqs;
2726 warn "iterate...";
2727 }
2728
2729 ++$RELOAD;
2730
2731 warn "cancelling all extension coros";
2732 $_->cancel for values %EXT_CORO;
2733 %EXT_CORO = ();
2734
2735 warn "removing commands";
2736 %COMMAND = ();
2737
2738 warn "removing ext commands";
2739 %EXTCMD = ();
2740
2741 warn "unloading/nuking all extensions";
2742 for my $pkg (@EXTS) {
2743 warn "... unloading $pkg";
2744
2745 if (my $cb = $pkg->can ("unload")) {
2746 eval {
2747 $cb->($pkg);
2748 1
2749 } or warn "$pkg unloaded, but with errors: $@";
1046 } 2750 }
1047 2751
2752 warn "... nuking $pkg";
2753 Symbol::delete_package $pkg;
2754 }
2755
1048 # unload all modules loaded from $LIBDIR 2756 warn "unloading all perl modules loaded from $LIBDIR";
1049 while (my ($k, $v) = each %INC) { 2757 while (my ($k, $v) = each %INC) {
1050 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2758 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1051 2759
1052 $msg->("removing <$k>"); 2760 warn "... unloading $k";
1053 delete $INC{$k}; 2761 delete $INC{$k};
1054 2762
1055 $k =~ s/\.pm$//; 2763 $k =~ s/\.pm$//;
1056 $k =~ s/\//::/g; 2764 $k =~ s/\//::/g;
1057 2765
1060 } 2768 }
1061 2769
1062 Symbol::delete_package $k; 2770 Symbol::delete_package $k;
1063 } 2771 }
1064 2772
1065 # sync database to disk
1066 cf::db_sync;
1067
1068 # get rid of safe::, as good as possible 2773 warn "getting rid of safe::, as good as possible";
1069 Symbol::delete_package "safe::$_" 2774 Symbol::delete_package "safe::$_"
1070 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region); 2775 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1071 2776
1072 # remove register_script_function callbacks
1073 # TODO
1074
1075 # unload cf.pm "a bit" 2777 warn "unloading cf.pm \"a bit\"";
1076 delete $INC{"cf.pm"}; 2778 delete $INC{"cf.pm"};
2779 delete $INC{"cf/pod.pm"};
1077 2780
1078 # don't, removes xs symbols, too, 2781 # don't, removes xs symbols, too,
1079 # and global variables created in xs 2782 # and global variables created in xs
1080 #Symbol::delete_package __PACKAGE__; 2783 #Symbol::delete_package __PACKAGE__;
1081 2784
1082 # reload cf.pm 2785 warn "unload completed, starting to reload now";
2786
1083 $msg->("reloading cf.pm"); 2787 warn "reloading cf.pm";
1084 require cf; 2788 require cf;
2789 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1085 2790
1086 # load database again 2791 warn "loading config and database again";
1087 cf::db_load; 2792 cf::cfg_load;
1088 2793
1089 # load extensions 2794 warn "loading extensions";
1090 $msg->("load extensions");
1091 cf::load_extensions; 2795 cf::load_extensions;
1092 2796
1093 # reattach attachments to objects 2797 warn "reattaching attachments to objects/players";
1094 $msg->("reattach"); 2798 _global_reattach; # objects, sockets
1095 _global_reattach; 2799 warn "reattaching attachments to maps";
2800 reattach $_ for values %MAP;
2801 warn "reattaching attachments to players";
2802 reattach $_ for values %PLAYER;
2803
2804 warn "leaving sync_job";
2805
2806 1
2807 } or do {
2808 warn $@;
2809 warn "error while reloading, exiting.";
2810 exit 1;
1096 }; 2811 };
1097 $msg->($@) if $@;
1098 2812
1099 $msg->("reloaded"); 2813 warn "reloaded";
1100}; 2814};
1101 2815
1102sub perl_reload() { 2816our $RELOAD_WATCHER; # used only during reload
1103 _perl_reload { 2817
1104 warn $_[0]; 2818sub reload_perl() {
1105 print "$_[0]\n"; 2819 # doing reload synchronously and two reloads happen back-to-back,
2820 # coro crashes during coro_state_free->destroy here.
2821
2822 $RELOAD_WATCHER ||= Event->timer (
2823 reentrant => 0,
2824 after => 0,
2825 data => WF_AUTOCANCEL,
2826 cb => sub {
2827 do_reload_perl;
2828 undef $RELOAD_WATCHER;
2829 },
1106 }; 2830 );
1107} 2831}
1108 2832
1109register_command "perl-reload", 0, sub { 2833register_command "reload" => sub {
1110 my ($who, $arg) = @_; 2834 my ($who, $arg) = @_;
1111 2835
1112 if ($who->flag (FLAG_WIZ)) { 2836 if ($who->flag (FLAG_WIZ)) {
1113 _perl_reload { 2837 $who->message ("reloading server.");
1114 warn $_[0]; 2838 async { reload_perl };
1115 $who->message ($_[0]); 2839 }
2840};
2841
2842unshift @INC, $LIBDIR;
2843
2844my $bug_warning = 0;
2845
2846our @WAIT_FOR_TICK;
2847our @WAIT_FOR_TICK_BEGIN;
2848
2849sub wait_for_tick {
2850 return unless $TICK_WATCHER->is_active;
2851 return if $Coro::current == $Coro::main;
2852
2853 my $signal = new Coro::Signal;
2854 push @WAIT_FOR_TICK, $signal;
2855 $signal->wait;
2856}
2857
2858sub wait_for_tick_begin {
2859 return unless $TICK_WATCHER->is_active;
2860 return if $Coro::current == $Coro::main;
2861
2862 my $signal = new Coro::Signal;
2863 push @WAIT_FOR_TICK_BEGIN, $signal;
2864 $signal->wait;
2865}
2866
2867 my $min = 1e6;#d#
2868 my $avg = 10;
2869$TICK_WATCHER = Event->timer (
2870 reentrant => 0,
2871 parked => 1,
2872 prio => 0,
2873 at => $NEXT_TICK || $TICK,
2874 data => WF_AUTOCANCEL,
2875 cb => sub {
2876 if ($Coro::current != $Coro::main) {
2877 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2878 unless ++$bug_warning > 10;
2879 return;
2880 }
2881
2882 $NOW = $tick_start = Event::time;
2883
2884 cf::server_tick; # one server iteration
2885
2886 0 && sync_job {#d#
2887 for(1..10) {
2888 my $t = Event::time;
2889 my $map = my $map = new_from_path cf::map "/tmp/x.map"
2890 or die;
2891
2892 $map->width (50);
2893 $map->height (50);
2894 $map->alloc;
2895 $map->_load_objects ("/tmp/x.map", 1);
2896 my $t = Event::time - $t;
2897
2898 #next unless $t < 0.0013;#d#
2899 if ($t < $min) {
2900 $min = $t;
2901 }
2902 $avg = $avg * 0.99 + $t * 0.01;
2903 }
2904 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2905 exit 0;
2906 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
1116 }; 2907 };
1117 }
1118};
1119 2908
1120register "<global>", __PACKAGE__; 2909 $RUNTIME += $TICK;
1121
1122unshift @INC, $LIBDIR;
1123
1124$TICK_WATCHER = Event->timer (
1125 prio => 1,
1126 at => $NEXT_TICK || 1,
1127 cb => sub {
1128 cf::server_tick; # one server iteration
1129
1130 my $NOW = Event::time;
1131 $NEXT_TICK += $TICK; 2910 $NEXT_TICK += $TICK;
1132 2911
2912 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2913 $NEXT_RUNTIME_WRITE = $NOW + 10;
2914 Coro::async_pool {
2915 write_runtime
2916 or warn "ERROR: unable to write runtime file: $!";
2917 };
2918 }
2919
2920# my $AFTER = Event::time;
2921# warn $AFTER - $NOW;#d#
2922
2923 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2924 $sig->send;
2925 }
2926 while (my $sig = shift @WAIT_FOR_TICK) {
2927 $sig->send;
2928 }
2929
2930 $NOW = Event::time;
2931
1133 # if we are delayed by four ticks, skip them all 2932 # if we are delayed by four ticks or more, skip them all
1134 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 2933 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1135 2934
1136 $TICK_WATCHER->at ($NEXT_TICK); 2935 $TICK_WATCHER->at ($NEXT_TICK);
1137 $TICK_WATCHER->start; 2936 $TICK_WATCHER->start;
2937
2938 $LOAD = ($NOW - $tick_start) / $TICK;
2939 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2940
2941 _post_tick;
2942
2943
1138 }, 2944 },
1139); 2945);
1140 2946
2947{
2948 BDB::max_poll_time $TICK * 0.1;
2949 $BDB_POLL_WATCHER = Event->io (
2950 reentrant => 0,
2951 fd => BDB::poll_fileno,
2952 poll => 'r',
2953 prio => 0,
2954 data => WF_AUTOCANCEL,
2955 cb => \&BDB::poll_cb,
2956 );
2957 BDB::min_parallel 8;
2958
2959 BDB::set_sync_prepare {
2960 my $status;
2961 my $current = $Coro::current;
2962 (
2963 sub {
2964 $status = $!;
2965 $current->ready; undef $current;
2966 },
2967 sub {
2968 Coro::schedule while defined $current;
2969 $! = $status;
2970 },
2971 )
2972 };
2973
2974 unless ($DB_ENV) {
2975 $DB_ENV = BDB::db_env_create;
2976
2977 cf::sync_job {
2978 eval {
2979 BDB::db_env_open
2980 $DB_ENV,
2981 $BDBDIR,
2982 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2983 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2984 0666;
2985
2986 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2987
2988 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2989 $DB_ENV->set_lk_detect;
2990 };
2991
2992 cf::cleanup "db_env_open(db): $@" if $@;
2993 };
2994 }
2995}
2996
2997{
2998 IO::AIO::min_parallel 8;
2999
3000 undef $Coro::AIO::WATCHER;
3001 IO::AIO::max_poll_time $TICK * 0.1;
3002 $AIO_POLL_WATCHER = Event->io (
3003 reentrant => 0,
3004 data => WF_AUTOCANCEL,
3005 fd => IO::AIO::poll_fileno,
3006 poll => 'r',
3007 prio => 6,
3008 cb => \&IO::AIO::poll_cb,
3009 );
3010}
3011
3012my $_log_backtrace;
3013
3014sub _log_backtrace {
3015 my ($msg, @addr) = @_;
3016
3017 $msg =~ s/\n//;
3018
3019 # limit the # of concurrent backtraces
3020 if ($_log_backtrace < 2) {
3021 ++$_log_backtrace;
3022 async {
3023 my @bt = fork_call {
3024 @addr = map { sprintf "%x", $_ } @addr;
3025 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3026 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3027 or die "addr2line: $!";
3028
3029 my @funcs;
3030 my @res = <$fh>;
3031 chomp for @res;
3032 while (@res) {
3033 my ($func, $line) = splice @res, 0, 2, ();
3034 push @funcs, "[$func] $line";
3035 }
3036
3037 @funcs
3038 };
3039
3040 LOG llevInfo, "[ABT] $msg\n";
3041 LOG llevInfo, "[ABT] $_\n" for @bt;
3042 --$_log_backtrace;
3043 };
3044 } else {
3045 LOG llevInfo, "[ABT] $msg\n";
3046 LOG llevInfo, "[ABT] [suppressed]\n";
3047 }
3048}
3049
3050# load additional modules
3051use cf::pod;
3052
3053END { cf::emergency_save }
3054
11411 30551
1142 3056

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines