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

Diff Legend

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