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.41 by root, Fri Aug 25 15:25:12 2006 UTC vs.
Revision 1.209 by root, Mon Feb 12 01:25:55 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';
41 157@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
42# generate property mutators 158@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
43sub prop_gen { 159@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
44 my ($prefix, $class) = @_; 160@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
45
46 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@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 161@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
77@safe::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
78 162
79# we bless all objects into (empty) derived classes to force a method lookup 163# we bless all objects into (empty) derived classes to force a method lookup
80# within the Safe compartment. 164# 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)) { 165for my $pkg (qw(
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)) {
82 no strict 'refs'; 172 no strict 'refs';
83 @{"safe::$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 = "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 safe::, as good as possible
412 Symbol::delete_package "safe::$_"
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 # and global variables created in xs
423 #Symbol::delete_package __PACKAGE__;
424
425 # 7. reload cf.pm
426 $msg->("reloading cf.pm");
427 require cf;
428 }; 1533 };
429 $msg->($@) if $@; 1534 $MAP_PREFETCHER->prio (6);
430 1535
431 $msg->("reloaded"); 1536 ()
432}; 1537}
433 1538
434sub perl_reload() { 1539sub save {
435 _perl_reload { 1540 my ($self) = @_;
436 warn $_[0]; 1541
437 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;
438 }; 1559 };
439}
440 1560
441register_command "perl-reload", 0, sub { 1561 if ($uniq) {
442 my ($who, $arg) = @_; 1562 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
443 1563 $self->_save_objects ($uniq, cf::IO_UNIQUES);
444 if ($who->flag (FLAG_WIZ)) {
445 _perl_reload {
446 warn $_[0];
447 $who->message ($_[0]);
448 };
449 }
450};
451
452#############################################################################
453# utility functions
454
455use JSON::Syck (); # TODO# replace by JSON::PC once working
456
457sub from_json($) {
458 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
459 JSON::Syck::Load $_[0]
460}
461
462sub to_json($) {
463 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
464 JSON::Syck::Dump $_[0]
465}
466
467#############################################################################
468# extcmd framework, basically convert ext <msg>
469# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
470
471sub on_extcmd {
472 my ($pl, $buf) = @_;
473
474 my $msg = eval { from_json $buf };
475
476 if (ref $msg) {
477 if (my $cb = $extcmd{$msg->{msgtype}}) {
478 if (my %reply = $cb->[0]->($pl, $msg)) {
479 $pl->ext_reply ($msg->{msgid}, %reply);
480 }
481 }
482 } else { 1564 } else {
483 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);
484 }
485
486 1
487}
488
489#############################################################################
490# load/save/clean perl data associated with a map
491
492*cf::mapsupport::on_clean = sub {
493 my ($map) = @_;
494
495 my $path = $map->tmpname;
496 defined $path or return;
497
498 unlink "$path.cfperl";
499};
500
501*cf::mapsupport::on_swapin =
502*cf::mapsupport::on_load = sub {
503 my ($map) = @_;
504
505 my $path = $map->tmpname;
506 $path = $map->path unless defined $path;
507
508 open my $fh, "<:raw", "$path.cfperl"
509 or return; # no perl data
510
511 my $data = Storable::thaw do { local $/; <$fh> };
512
513 $data->{version} <= 1
514 or return; # too new
515
516 $map->_set_obs ($data->{obs});
517};
518
519*cf::mapsupport::on_swapout = sub {
520 my ($map) = @_;
521
522 my $path = $map->tmpname;
523 $path = $map->path unless defined $path;
524
525 my $obs = $map->_get_obs;
526
527 if (defined $obs) {
528 open my $fh, ">:raw", "$path.cfperl"
529 or die "$path.cfperl: $!";
530
531 stat $path;
532
533 print $fh Storable::nfreeze {
534 size => (stat _)[7],
535 time => (stat _)[9],
536 version => 1,
537 obs => $obs,
538 };
539
540 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
541 } else {
542 unlink "$path.cfperl";
543 }
544};
545
546attach_to_maps prio => -10000, package => cf::mapsupport::;
547
548#############################################################################
549# load/save perl data associated with player->ob objects
550
551sub all_objects(@) {
552 @_, map all_objects ($_->inv), @_
553}
554
555attach_to_players
556 on_load => sub {
557 my ($pl, $path) = @_;
558
559 for my $o (all_objects $pl->ob) {
560 if (my $value = $o->get_ob_key_value ("_perl_data")) {
561 $o->set_ob_key_value ("_perl_data");
562
563 %$o = %{ Storable::thaw pack "H*", $value };
564 }
565 }
566 }, 1566 }
567 on_save => sub { 1567}
568 my ($pl, $path) = @_;
569 1568
570 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_) 1569sub swap_out {
571 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 delete $cf::MAP{$self->path};
1615
1616 $self->in_memory (cf::MAP_SWAPPED);
1617 $self->clear;
1618
1619 $_->clear_links_to ($self) for values %cf::MAP;
1620
1621 $self->unlink_save;
1622 $self->destroy;
1623}
1624
1625my $nuke_counter = "aaaa";
1626
1627sub nuke {
1628 my ($self) = @_;
1629
1630 delete $cf::MAP{$self->path};
1631
1632 $self->unlink_save;
1633
1634 bless $self, "cf::map";
1635 delete $self->{deny_reset};
1636 $self->{deny_save} = 1;
1637 $self->reset_timeout (1);
1638 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1639
1640 $cf::MAP{$self->path} = $self;
1641
1642 $self->reset; # polite request, might not happen
1643}
1644
1645=item cf::map::unique_maps
1646
1647Returns an arrayref of paths of all shared maps that have
1648instantiated unique items. May block.
1649
1650=cut
1651
1652sub unique_maps() {
1653 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1654 or return;
1655
1656 my @paths;
1657
1658 for (@$files) {
1659 utf8::decode $_;
1660 next if /\.pst$/;
1661 next unless /^$PATH_SEP/o;
1662
1663 push @paths, cf::map::normalise $_;
572 }, 1664 }
573;
574 1665
575############################################################################# 1666 \@paths
576# core extensions - in perl
577
578=item cf::player::exists $login
579
580Returns true when the given account exists.
581
582=cut
583
584sub cf::player::exists($) {
585 cf::player::find $_[0]
586 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
587} 1667}
588 1668
1669package cf;
1670
1671=back
1672
1673=head3 cf::object
1674
1675=cut
1676
1677package cf::object;
1678
1679=over 4
1680
1681=item $ob->inv_recursive
1682
1683Returns the inventory of the object _and_ their inventories, recursively.
1684
1685=cut
1686
1687sub inv_recursive_;
1688sub inv_recursive_ {
1689 map { $_, inv_recursive_ $_->inv } @_
1690}
1691
1692sub inv_recursive {
1693 inv_recursive_ inv $_[0]
1694}
1695
1696package cf;
1697
1698=back
1699
1700=head3 cf::object::player
1701
1702=over 4
1703
589=item $player->reply ($npc, $msg[, $flags]) 1704=item $player_object->reply ($npc, $msg[, $flags])
590 1705
591Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 1706Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
592can be C<undef>. Does the right thing when the player is currently in a 1707can be C<undef>. Does the right thing when the player is currently in a
593dialogue with the given NPC character. 1708dialogue with the given NPC character.
594 1709
595=cut 1710=cut
596 1711
597# rough implementation of a future "reply" method that works 1712# rough implementation of a future "reply" method that works
598# with dialog boxes. 1713# with dialog boxes.
1714#TODO: the first argument must go, split into a $npc->reply_to ( method
599sub cf::object::player::reply($$$;$) { 1715sub cf::object::player::reply($$$;$) {
600 my ($self, $npc, $msg, $flags) = @_; 1716 my ($self, $npc, $msg, $flags) = @_;
601 1717
602 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 1718 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
603 1719
… …
607 $msg = $npc->name . " says: $msg" if $npc; 1723 $msg = $npc->name . " says: $msg" if $npc;
608 $self->message ($msg, $flags); 1724 $self->message ($msg, $flags);
609 } 1725 }
610} 1726}
611 1727
612=item $player->ext_reply ($msgid, $msgtype, %msg) 1728=item $player_object->may ("access")
613 1729
614Sends an ext reply to the player. 1730Returns wether the given player is authorized to access resource "access"
1731(e.g. "command_wizcast").
615 1732
616=cut 1733=cut
617 1734
618sub cf::player::ext_reply($$$%) { 1735sub cf::object::player::may {
1736 my ($self, $access) = @_;
1737
1738 $self->flag (cf::FLAG_WIZ) ||
1739 (ref $cf::CFG{"may_$access"}
1740 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
1741 : $cf::CFG{"may_$access"})
1742}
1743
1744=item $player_object->enter_link
1745
1746Freezes the player and moves him/her to a special map (C<{link}>).
1747
1748The player should be reasonably safe there for short amounts of time. You
1749I<MUST> call C<leave_link> as soon as possible, though.
1750
1751Will never block.
1752
1753=item $player_object->leave_link ($map, $x, $y)
1754
1755Moves the player out of the special C<{link}> map onto the specified
1756map. If the map is not valid (or omitted), the player will be moved back
1757to the location he/she was before the call to C<enter_link>, or, if that
1758fails, to the emergency map position.
1759
1760Might block.
1761
1762=cut
1763
1764sub link_map {
1765 unless ($LINK_MAP) {
1766 $LINK_MAP = cf::map::find "{link}"
1767 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1768 $LINK_MAP->load;
1769 }
1770
1771 $LINK_MAP
1772}
1773
1774sub cf::object::player::enter_link {
1775 my ($self) = @_;
1776
1777 $self->deactivate_recursive;
1778
1779 return if UNIVERSAL::isa $self->map, "ext::map_link";
1780
1781 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1782 if $self->map;
1783
1784 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1785}
1786
1787sub cf::object::player::leave_link {
1788 my ($self, $map, $x, $y) = @_;
1789
1790 my $link_pos = delete $self->{_link_pos};
1791
1792 unless ($map) {
1793 # restore original map position
1794 ($map, $x, $y) = @{ $link_pos || [] };
1795 $map = cf::map::find $map;
1796
1797 unless ($map) {
1798 ($map, $x, $y) = @$EMERGENCY_POSITION;
1799 $map = cf::map::find $map
1800 or die "FATAL: cannot load emergency map\n";
1801 }
1802 }
1803
1804 ($x, $y) = (-1, -1)
1805 unless (defined $x) && (defined $y);
1806
1807 # use -1 or undef as default coordinates, not 0, 0
1808 ($x, $y) = ($map->enter_x, $map->enter_y)
1809 if $x <=0 && $y <= 0;
1810
1811 $map->load;
1812 $map->load_diag;
1813
1814 return unless $self->contr->active;
1815 $self->activate_recursive;
1816 $self->enter_map ($map, $x, $y);
1817}
1818
1819cf::player->attach (
1820 on_logout => sub {
1821 my ($pl) = @_;
1822
1823 # abort map switching before logout
1824 if ($pl->ob->{_link_pos}) {
1825 cf::sync_job {
1826 $pl->ob->leave_link
1827 };
1828 }
1829 },
1830 on_login => sub {
1831 my ($pl) = @_;
1832
1833 # try to abort aborted map switching on player login :)
1834 # should happen only on crashes
1835 if ($pl->ob->{_link_pos}) {
1836 $pl->ob->enter_link;
1837 (async {
1838 # we need this sleep as the login has a concurrent enter_exit running
1839 # and this sleep increases chances of the player not ending up in scorn
1840 $pl->ob->reply (undef,
1841 "There was an internal problem at your last logout, "
1842 . "the server will try to bring you to your intended destination in a second.",
1843 cf::NDI_RED);
1844 Coro::Timer::sleep 1;
1845 $pl->ob->leave_link;
1846 })->prio (2);
1847 }
1848 },
1849);
1850
1851=item $player_object->goto ($path, $x, $y)
1852
1853=cut
1854
1855sub cf::object::player::goto {
1856 my ($self, $path, $x, $y) = @_;
1857
1858 $self->enter_link;
1859
1860 (async {
1861 my $map = eval {
1862 my $map = cf::map::find $path;
1863 $map = $map->customise_for ($self) if $map;
1864 $map
1865 } or
1866 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1867
1868 $self->leave_link ($map, $x, $y);
1869 })->prio (1);
1870}
1871
1872=item $player_object->enter_exit ($exit_object)
1873
1874=cut
1875
1876sub parse_random_map_params {
1877 my ($spec) = @_;
1878
1879 my $rmp = { # defaults
1880 xsize => (cf::rndm 15, 40),
1881 ysize => (cf::rndm 15, 40),
1882 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
1883 #layout => string,
1884 };
1885
1886 for (split /\n/, $spec) {
1887 my ($k, $v) = split /\s+/, $_, 2;
1888
1889 $rmp->{lc $k} = $v if (length $k) && (length $v);
1890 }
1891
1892 $rmp
1893}
1894
1895sub prepare_random_map {
1896 my ($exit) = @_;
1897
1898 my $guard = cf::lock_acquire "exit_prepare:$exit";
1899
1900 # all this does is basically replace the /! path by
1901 # a new random map path (?random/...) with a seed
1902 # that depends on the exit object
1903
1904 my $rmp = parse_random_map_params $exit->msg;
1905
1906 if ($exit->map) {
1907 $rmp->{region} = $exit->region->name;
1908 $rmp->{origin_map} = $exit->map->path;
1909 $rmp->{origin_x} = $exit->x;
1910 $rmp->{origin_y} = $exit->y;
1911 }
1912
1913 $rmp->{random_seed} ||= $exit->random_seed;
1914
1915 my $data = cf::to_json $rmp;
1916 my $md5 = Digest::MD5::md5_hex $data;
1917 my $meta = "$cf::RANDOM_MAPS/$md5.meta";
1918
1919 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1920 aio_write $fh, 0, (length $data), $data, 0;
1921 undef $fh;
1922 aio_rename "$meta~", $meta;
1923
1924 $exit->slaying ("?random/$md5");
1925 $exit->msg (undef);
1926 }
1927}
1928
1929sub cf::object::player::enter_exit {
619 my ($self, $id, %msg) = @_; 1930 my ($self, $exit) = @_;
620 1931
621 $msg{msgid} = $id; 1932 return unless $self->type == cf::PLAYER;
622 1933
623 $self->send ("ext " . to_json \%msg); 1934 if ($exit->slaying eq "/!") {
624} 1935 #TODO: this should de-fi-ni-te-ly not be a sync-job
1936 cf::sync_job { prepare_random_map $exit };
1937 }
625 1938
626############################################################################# 1939 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
627# map scripting support 1940 my $hp = $exit->stats->hp;
1941 my $sp = $exit->stats->sp;
628 1942
1943 $self->enter_link;
1944
1945 (async {
1946 $self->deactivate_recursive; # just to be sure
1947 unless (eval {
1948 $self->goto ($slaying, $hp, $sp);
1949
1950 1;
1951 }) {
1952 $self->message ("Something went wrong deep within the crossfire server. "
1953 . "I'll try to bring you back to the map you were before. "
1954 . "Please report this to the dungeon master!",
1955 cf::NDI_UNIQUE | cf::NDI_RED);
1956
1957 warn "ERROR in enter_exit: $@";
1958 $self->leave_link;
1959 }
1960 })->prio (1);
1961}
1962
1963=head3 cf::client
1964
1965=over 4
1966
1967=item $client->send_drawinfo ($text, $flags)
1968
1969Sends a drawinfo packet to the client. Circumvents output buffering so
1970should not be used under normal circumstances.
1971
1972=cut
1973
1974sub cf::client::send_drawinfo {
1975 my ($self, $text, $flags) = @_;
1976
1977 utf8::encode $text;
1978 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text);
1979}
1980
1981
1982=item $success = $client->query ($flags, "text", \&cb)
1983
1984Queues a query to the client, calling the given callback with
1985the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1986C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1987
1988Queries can fail, so check the return code. Or don't, as queries will become
1989reliable at some point in the future.
1990
1991=cut
1992
1993sub cf::client::query {
1994 my ($self, $flags, $text, $cb) = @_;
1995
1996 return unless $self->state == ST_PLAYING
1997 || $self->state == ST_SETUP
1998 || $self->state == ST_CUSTOM;
1999
2000 $self->state (ST_CUSTOM);
2001
2002 utf8::encode $text;
2003 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2004
2005 $self->send_packet ($self->{query_queue}[0][0])
2006 if @{ $self->{query_queue} } == 1;
2007}
2008
2009cf::client->attach (
2010 on_reply => sub {
2011 my ($ns, $msg) = @_;
2012
2013 # this weird shuffling is so that direct followup queries
2014 # get handled first
2015 my $queue = delete $ns->{query_queue}
2016 or return; # be conservative, not sure how that can happen, but we saw a crash here
2017
2018 (shift @$queue)->[1]->($msg);
2019 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
2020
2021 push @{ $ns->{query_queue} }, @$queue;
2022
2023 if (@{ $ns->{query_queue} } == @$queue) {
2024 if (@$queue) {
2025 $ns->send_packet ($ns->{query_queue}[0][0]);
2026 } else {
2027 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2028 }
2029 }
2030 },
2031);
2032
2033=item $client->async (\&cb)
2034
2035Create a new coroutine, running the specified callback. The coroutine will
2036be automatically cancelled when the client gets destroyed (e.g. on logout,
2037or loss of connection).
2038
2039=cut
2040
2041sub cf::client::async {
2042 my ($self, $cb) = @_;
2043
2044 my $coro = &Coro::async ($cb);
2045
2046 $coro->on_destroy (sub {
2047 delete $self->{_coro}{$coro+0};
2048 });
2049
2050 $self->{_coro}{$coro+0} = $coro;
2051
2052 $coro
2053}
2054
2055cf::client->attach (
2056 on_destroy => sub {
2057 my ($ns) = @_;
2058
2059 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2060 },
2061);
2062
2063=back
2064
2065
2066=head2 SAFE SCRIPTING
2067
2068Functions that provide a safe environment to compile and execute
2069snippets of perl code without them endangering the safety of the server
2070itself. Looping constructs, I/O operators and other built-in functionality
2071is not available in the safe scripting environment, and the number of
2072functions and methods that can be called is greatly reduced.
2073
2074=cut
2075
629our $safe = new Safe "ext"; 2076our $safe = new Safe "safe";
630our $safe_hole = new Safe::Hole; 2077our $safe_hole = new Safe::Hole;
631 2078
632$SIG{FPE} = 'IGNORE'; 2079$SIG{FPE} = 'IGNORE';
633 2080
634$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2081$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
635 2082
636# here we export the classes and methods available to script code 2083# here we export the classes and methods available to script code
637 2084
2085=pod
2086
2087The following fucntions and emthods are available within a safe environment:
2088
2089 cf::object contr pay_amount pay_player map
2090 cf::object::player player
2091 cf::player peaceful
2092 cf::map trigger
2093
2094=cut
2095
638for ( 2096for (
639 ["cf::object" => qw(contr pay_amount pay_player)], 2097 ["cf::object" => qw(contr pay_amount pay_player map)],
640 ["cf::object::player" => qw(player)], 2098 ["cf::object::player" => qw(player)],
641 ["cf::player" => qw(peaceful)], 2099 ["cf::player" => qw(peaceful)],
2100 ["cf::map" => qw(trigger)],
642) { 2101) {
643 no strict 'refs'; 2102 no strict 'refs';
644 my ($pkg, @funs) = @$_; 2103 my ($pkg, @funs) = @$_;
645 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 2104 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
646 for @funs; 2105 for @funs;
647} 2106}
648 2107
2108=over 4
2109
2110=item @retval = safe_eval $code, [var => value, ...]
2111
2112Compiled and executes the given perl code snippet. additional var/value
2113pairs result in temporary local (my) scalar variables of the given name
2114that are available in the code snippet. Example:
2115
2116 my $five = safe_eval '$first + $second', first => 1, second => 4;
2117
2118=cut
2119
649sub safe_eval($;@) { 2120sub safe_eval($;@) {
650 my ($code, %vars) = @_; 2121 my ($code, %vars) = @_;
651 2122
652 my $qcode = $code; 2123 my $qcode = $code;
653 $qcode =~ s/"/‟/g; # not allowed in #line filenames 2124 $qcode =~ s/"/‟/g; # not allowed in #line filenames
654 $qcode =~ s/\n/\\n/g; 2125 $qcode =~ s/\n/\\n/g;
655 2126
656 local $_; 2127 local $_;
657 local @safe::cf::_safe_eval_args = values %vars; 2128 local @safe::cf::_safe_eval_args = values %vars;
658 2129
659 $code = 2130 my $eval =
660 "do {\n" 2131 "do {\n"
661 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 2132 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
662 . "#line 0 \"{$qcode}\"\n" 2133 . "#line 0 \"{$qcode}\"\n"
663 . $code 2134 . $code
664 . "\n}" 2135 . "\n}"
665 ; 2136 ;
666 2137
667 sub_generation_inc; 2138 sub_generation_inc;
668 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 2139 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
669 sub_generation_inc; 2140 sub_generation_inc;
670 2141
2142 if ($@) {
2143 warn "$@";
2144 warn "while executing safe code '$code'\n";
2145 warn "with arguments " . (join " ", %vars) . "\n";
2146 }
2147
671 wantarray ? @res : $res[0] 2148 wantarray ? @res : $res[0]
672} 2149}
2150
2151=item cf::register_script_function $function => $cb
2152
2153Register a function that can be called from within map/npc scripts. The
2154function should be reasonably secure and should be put into a package name
2155like the extension.
2156
2157Example: register a function that gets called whenever a map script calls
2158C<rent::overview>, as used by the C<rent> extension.
2159
2160 cf::register_script_function "rent::overview" => sub {
2161 ...
2162 };
2163
2164=cut
673 2165
674sub register_script_function { 2166sub register_script_function {
675 my ($fun, $cb) = @_; 2167 my ($fun, $cb) = @_;
676 2168
677 no strict 'refs'; 2169 no strict 'refs';
678 *{"safe::$fun"} = $safe_hole->wrap ($cb); 2170 *{"safe::$fun"} = $safe_hole->wrap ($cb);
679} 2171}
680 2172
2173=back
2174
2175=cut
2176
681############################################################################# 2177#############################################################################
682# the server's main() 2178
2179=head2 EXTENSION DATABASE SUPPORT
2180
2181Crossfire maintains a very simple database for extension use. It can
2182currently store anything that can be serialised using Storable, which
2183excludes objects.
2184
2185The parameter C<$family> should best start with the name of the extension
2186using it, it should be unique.
2187
2188=over 4
2189
2190=item $value = cf::db_get $family => $key
2191
2192Returns a single value from the database.
2193
2194=item cf::db_put $family => $key => $value
2195
2196Stores the given C<$value> in the family.
2197
2198=cut
2199
2200our $DB;
2201
2202unless ($DB) {
2203 $DB = BDB::db_create $DB_ENV;
2204
2205 cf::sync_job {
2206 eval {
2207 $DB->set_flags (BDB::CHKSUM);
2208
2209 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2210 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2211 cf::cleanup "db_open(db): $!" if $!;
2212 };
2213 cf::cleanup "db_open(db): $@" if $@;
2214 };
2215
2216 my $path = cf::localdir . "/database.pst";
2217 if (stat $path) {
2218 cf::sync_job {
2219 my $pst = Storable::retrieve $path;
2220
2221 cf::db_put (board => data => $pst->{board});
2222 cf::db_put (guildrules => data => $pst->{guildrules});
2223 cf::db_put (rent => balance => $pst->{rent}{balance});
2224 BDB::db_env_txn_checkpoint $DB_ENV;
2225
2226 unlink $path;
2227 };
2228 }
2229}
2230
2231sub db_get($$) {
2232 my $key = "$_[0]/$_[1]";
2233
2234 cf::sync_job {
2235 BDB::db_get $DB, undef, $key, my $data;
2236
2237 $! ? ()
2238 : Compress::LZF::sthaw $data
2239 }
2240}
2241
2242sub db_put($$$) {
2243 BDB::dbreq_pri 4;
2244 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
2245}
2246
2247#############################################################################
2248# the server's init and main functions
2249
2250sub load_resources {
2251 load_regions sprintf "%s/%s/regions", cf::datadir, cf::mapdir
2252 or die "unable to load regions file\n";#d#
2253}
2254
2255sub cfg_load {
2256 open my $fh, "<:utf8", cf::confdir . "/config"
2257 or return;
2258
2259 local $/;
2260 *CFG = YAML::Syck::Load <$fh>;
2261
2262 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2263
2264 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2265 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2266
2267 if (exists $CFG{mlockall}) {
2268 eval {
2269 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2270 and die "WARNING: m(un)lockall failed: $!\n";
2271 };
2272 warn $@ if $@;
2273 }
2274}
2275
2276sub init {
2277 load_resources;
2278}
683 2279
684sub main { 2280sub main {
2281 # we must not ever block the main coroutine
2282 local $Coro::idle = sub {
2283 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2284 (async {
2285 Event::one_event;
2286 })->prio (Coro::PRIO_MAX);
2287 };
2288
2289 cfg_load;
2290 load_extensions;
2291
2292 $TICK_WATCHER->start;
685 Event::loop; 2293 Event::loop;
686} 2294}
687 2295
688############################################################################# 2296#############################################################################
689# initialisation 2297# initialisation and cleanup
690 2298
691register "<global>", __PACKAGE__; 2299# install some emergency cleanup handlers
2300BEGIN {
2301 for my $signal (qw(INT HUP TERM)) {
2302 Event->signal (
2303 reentrant => 0,
2304 data => WF_AUTOCANCEL,
2305 signal => $signal,
2306 prio => 0,
2307 cb => sub {
2308 cf::cleanup "SIG$signal";
2309 },
2310 );
2311 }
2312}
2313
2314sub emergency_save() {
2315 my $freeze_guard = cf::freeze_mainloop;
2316
2317 warn "enter emergency perl save\n";
2318
2319 cf::sync_job {
2320 # use a peculiar iteration method to avoid tripping on perl
2321 # refcount bugs in for. also avoids problems with players
2322 # and maps saved/destroyed asynchronously.
2323 warn "begin emergency player save\n";
2324 for my $login (keys %cf::PLAYER) {
2325 my $pl = $cf::PLAYER{$login} or next;
2326 $pl->valid or next;
2327 $pl->save;
2328 }
2329 warn "end emergency player save\n";
2330
2331 warn "begin emergency map save\n";
2332 for my $path (keys %cf::MAP) {
2333 my $map = $cf::MAP{$path} or next;
2334 $map->valid or next;
2335 $map->save;
2336 }
2337 warn "end emergency map save\n";
2338
2339 warn "begin emergency database checkpoint\n";
2340 BDB::db_env_txn_checkpoint $DB_ENV;
2341 warn "end emergency database checkpoint\n";
2342 };
2343
2344 warn "leave emergency perl save\n";
2345}
2346
2347sub reload() {
2348 # can/must only be called in main
2349 if ($Coro::current != $Coro::main) {
2350 warn "can only reload from main coroutine";
2351 return;
2352 }
2353
2354 warn "reloading...";
2355
2356 warn "cancelling server ticker";
2357 $TICK_WATCHER->cancel;
2358
2359 cf::emergency_save;
2360
2361 eval {
2362 # if anything goes wrong in here, we should simply crash as we already saved
2363
2364 warn "cancelling all WF_AUTOCANCEL watchers";
2365 for (Event::all_watchers) {
2366 $_->cancel if $_->data & WF_AUTOCANCEL;
2367 }
2368
2369 warn "syncing database to disk";
2370 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
2371
2372 warn "flushing outstanding aio requests";
2373 for (;;) {
2374 BDB::flush;
2375 IO::AIO::flush;
2376 Coro::cede;
2377 last unless IO::AIO::nreqs || BDB::nreqs;
2378 warn "iterate...";
2379 }
2380
2381 warn "cancelling all extension coros";
2382 $_->cancel for values %EXT_CORO;
2383 %EXT_CORO = ();
2384
2385 warn "removing commands";
2386 %COMMAND = ();
2387
2388 warn "removing ext commands";
2389 %EXTCMD = ();
2390
2391 warn "unloading/nuking all extensions";
2392 for my $pkg (@EXTS) {
2393 warn "... unloading $pkg";
2394
2395 if (my $cb = $pkg->can ("unload")) {
2396 eval {
2397 $cb->($pkg);
2398 1
2399 } or warn "$pkg unloaded, but with errors: $@";
2400 }
2401
2402 warn "... nuking $pkg";
2403 Symbol::delete_package $pkg;
2404 }
2405
2406 warn "unloading all perl modules loaded from $LIBDIR";
2407 while (my ($k, $v) = each %INC) {
2408 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2409
2410 warn "... unloading $k";
2411 delete $INC{$k};
2412
2413 $k =~ s/\.pm$//;
2414 $k =~ s/\//::/g;
2415
2416 if (my $cb = $k->can ("unload_module")) {
2417 $cb->();
2418 }
2419
2420 Symbol::delete_package $k;
2421 }
2422
2423 warn "getting rid of safe::, as good as possible";
2424 Symbol::delete_package "safe::$_"
2425 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2426
2427 warn "unloading cf.pm \"a bit\"";
2428 delete $INC{"cf.pm"};
2429
2430 # don't, removes xs symbols, too,
2431 # and global variables created in xs
2432 #Symbol::delete_package __PACKAGE__;
2433
2434 warn "unload completed, starting to reload now";
2435
2436 warn "reloading cf.pm";
2437 require cf;
2438 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2439
2440 warn "loading config and database again";
2441 cf::cfg_load;
2442
2443 warn "loading extensions";
2444 cf::load_extensions;
2445
2446 warn "reattaching attachments to objects/players";
2447 _global_reattach;
2448 warn "reattaching attachments to maps";
2449 reattach $_ for values %MAP;
2450
2451 warn "loading reloadable resources";
2452 load_resources;
2453
2454 warn "restarting server ticker";
2455
2456 $TICK_WATCHER->start;
2457 };
2458
2459 if ($@) {
2460 warn $@;
2461 warn "error while reloading, exiting.";
2462 exit 1;
2463 }
2464
2465 warn "reloaded";
2466};
2467
2468our $RELOAD_WATCHER; # used only during reload
2469
2470register_command "reload" => sub {
2471 my ($who, $arg) = @_;
2472
2473 if ($who->flag (FLAG_WIZ)) {
2474 $who->message ("reloading server.");
2475
2476 # doing reload synchronously and two reloads happen back-to-back,
2477 # coro crashes during coro_state_free->destroy here.
2478
2479 $RELOAD_WATCHER ||= Event->timer (
2480 reentrant => 0,
2481 after => 0,
2482 data => WF_AUTOCANCEL,
2483 cb => sub {
2484 reload;
2485 undef $RELOAD_WATCHER;
2486 },
2487 );
2488 }
2489};
692 2490
693unshift @INC, $LIBDIR; 2491unshift @INC, $LIBDIR;
694 2492
695load_extensions; 2493my $bug_warning = 0;
696 2494
697$TICK_WATCHER = Event->timer ( 2495$TICK_WATCHER = Event->timer (
2496 reentrant => 0,
2497 parked => 1,
698 prio => 1, 2498 prio => 0,
699 at => $NEXT_TICK || 1, 2499 at => $NEXT_TICK || $TICK,
2500 data => WF_AUTOCANCEL,
700 cb => sub { 2501 cb => sub {
2502 if ($Coro::current != $Coro::main) {
2503 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2504 unless ++$bug_warning > 10;
2505 return;
2506 }
2507
2508 $NOW = Event::time;
2509
701 cf::server_tick; # one server iteration 2510 cf::server_tick; # one server iteration
702 2511 $RUNTIME += $TICK;
703 my $NOW = Event::time;
704 $NEXT_TICK += $TICK; 2512 $NEXT_TICK += $TICK;
705 2513
2514 $WAIT_FOR_TICK->broadcast;
2515 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2516
2517 Event::sweep;
2518 Coro::cede_notself;
2519
2520# my $AFTER = Event::time;
2521# warn $AFTER - $NOW;#d#
2522
706 # if we are delayed by four ticks, skip them all 2523 # if we are delayed by four ticks or more, skip them all
707 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 2524 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
708 2525
709 $TICK_WATCHER->at ($NEXT_TICK); 2526 $TICK_WATCHER->at ($NEXT_TICK);
710 $TICK_WATCHER->start; 2527 $TICK_WATCHER->start;
711 }, 2528 },
712); 2529);
713 2530
2531{
2532 BDB::max_poll_time $TICK * 0.1;
2533 $BDB_POLL_WATCHER = Event->io (
2534 reentrant => 0,
2535 fd => BDB::poll_fileno,
2536 poll => 'r',
2537 prio => 0,
2538 data => WF_AUTOCANCEL,
2539 cb => \&BDB::poll_cb,
2540 );
2541 BDB::min_parallel 8;
2542
2543 BDB::set_sync_prepare {
2544 my $status;
2545 my $current = $Coro::current;
2546 (
2547 sub {
2548 $status = $!;
2549 $current->ready; undef $current;
2550 },
2551 sub {
2552 Coro::schedule while defined $current;
2553 $! = $status;
2554 },
2555 )
2556 };
2557
2558 unless ($DB_ENV) {
2559 $DB_ENV = BDB::db_env_create;
2560
2561 cf::sync_job {
2562 eval {
2563 BDB::db_env_open
2564 $DB_ENV,
2565 $BDB_ENV_DIR,
2566 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2567 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2568 0666;
2569
2570 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!;
2571
2572 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2573 $DB_ENV->set_lk_detect;
2574 };
2575
2576 cf::cleanup "db_env_open(db): $@" if $@;
2577 };
2578 }
2579}
2580
2581{
2582 IO::AIO::min_parallel 8;
2583
2584 undef $Coro::AIO::WATCHER;
2585 IO::AIO::max_poll_time $TICK * 0.1;
2586 $AIO_POLL_WATCHER = Event->io (
2587 reentrant => 0,
2588 fd => IO::AIO::poll_fileno,
2589 poll => 'r',
2590 prio => 6,
2591 data => WF_AUTOCANCEL,
2592 cb => \&IO::AIO::poll_cb,
2593 );
2594}
2595
2596$WRITE_RUNTIME_WATCHER = Event->timer (
2597 reentrant => 0,
2598 data => WF_AUTOCANCEL,
2599 after => 1,
2600 interval => 10,
2601 prio => 6, # keep it lowest so it acts like a watchdog
2602 cb => Coro::unblock_sub {
2603 write_runtime
2604 or warn "ERROR: unable to write runtime file: $!";
2605 },
2606);
2607
2608END { cf::emergency_save }
2609
7141 26101
715 2611

Diff Legend

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