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.40 by root, Fri Aug 25 15:21:57 2006 UTC vs.
Revision 1.212 by root, Tue Feb 13 19:25:44 2007 UTC

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

Diff Legend

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