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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines