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

Diff Legend

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