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.38 by root, Thu Aug 24 17:29:30 2006 UTC vs.
Revision 1.103 by root, Sat Dec 30 10:16:11 2006 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.3;
14use Coro::Event;
15use Coro::Timer;
16use Coro::Signal;
17use Coro::Semaphore;
18
19use IO::AIO 2.3;
20use YAML::Syck ();
10use Time::HiRes; 21use Time::HiRes;
11use Event; 22
12$Event::Eval = 1; # no idea why this is required, but it is 23use Event; $Event::Eval = 1; # no idea why this is required, but it is
13 24
14use strict; 25# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
26$YAML::Syck::ImplicitUnicode = 1;
15 27
16our %COMMAND; 28$Coro::main->prio (2); # run main coroutine ("the server") with very high priority
29
30sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
31
32our %COMMAND = ();
33our %COMMAND_TIME = ();
34our %EXTCMD = ();
35
17our @EVENT; 36our @EVENT;
18our @PLUGIN_EVENT; 37our $LIBDIR = datadir . "/ext";
19our %PROP_TYPE;
20our %PROP_IDX;
21our $LIBDIR = maps_directory "perl";
22 38
23our $TICK = MAX_TIME * 1e-6; 39our $TICK = MAX_TIME * 1e-6;
24our $TICK_WATCHER; 40our $TICK_WATCHER;
25our $NEXT_TICK; 41our $NEXT_TICK;
42our $NOW;
43
44our %CFG;
45
46our $UPTIME; $UPTIME ||= time;
47our $RUNTIME;
48
49our %MAP; # all maps
50our $LINK_MAP; # the special {link} map
51our $FREEZE;
52
53binmode STDOUT;
54binmode STDERR;
55
56# read virtual server time, if available
57unless ($RUNTIME || !-e cf::localdir . "/runtime") {
58 open my $fh, "<", cf::localdir . "/runtime"
59 or die "unable to read runtime file: $!";
60 $RUNTIME = <$fh> + 0.;
61}
62
63mkdir cf::localdir;
64mkdir cf::localdir . "/" . cf::playerdir;
65mkdir cf::localdir . "/" . cf::tmpdir;
66mkdir cf::localdir . "/" . cf::uniquedir;
67
68our %EXT_CORO;
69
70#############################################################################
71
72=head2 GLOBAL VARIABLES
73
74=over 4
75
76=item $cf::UPTIME
77
78The timestamp of the server start (so not actually an uptime).
79
80=item $cf::RUNTIME
81
82The time this server has run, starts at 0 and is increased by $cf::TICK on
83every server tick.
84
85=item $cf::LIBDIR
86
87The perl library directory, where extensions and cf-specific modules can
88be found. It will be added to C<@INC> automatically.
89
90=item $cf::NOW
91
92The time of the last (current) server tick.
93
94=item $cf::TICK
95
96The interval between server ticks, in seconds.
97
98=item %cf::CFG
99
100Configuration for the server, loaded from C</etc/crossfire/config>, or
101from wherever your confdir points to.
102
103=back
104
105=cut
26 106
27BEGIN { 107BEGIN {
28 @PLUGIN_EVENT = map lc, @PLUGIN_EVENT;
29
30 *CORE::GLOBAL::warn = sub { 108 *CORE::GLOBAL::warn = sub {
31 my $msg = join "", @_; 109 my $msg = join "", @_;
110 utf8::encode $msg;
111
32 $msg .= "\n" 112 $msg .= "\n"
33 unless $msg =~ /\n$/; 113 unless $msg =~ /\n$/;
34 114
35 print STDERR "cfperl: $msg";
36 LOG llevError, "cfperl: $msg"; 115 LOG llevError, "cfperl: $msg";
37 }; 116 };
38} 117}
39 118
40my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply! 119@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
120@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
121@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
122@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
123@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
124@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
41 125
42# generate property mutators 126# we bless all objects into (empty) derived classes to force a method lookup
43sub prop_gen { 127# within the Safe compartment.
44 my ($prefix, $class) = @_; 128for my $pkg (qw(
45 129 cf::global cf::attachable
130 cf::object cf::object::player
131 cf::client cf::player
132 cf::arch cf::living
133 cf::map cf::party cf::region
134)) {
46 no strict 'refs'; 135 no strict 'refs';
47
48 for my $prop (keys %PROP_TYPE) {
49 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
50 my $sub = lc $1;
51
52 my $type = $PROP_TYPE{$prop};
53 my $idx = $PROP_IDX {$prop};
54
55 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
56 $_[0]->get_property ($type, $idx)
57 };
58
59 *{"$class\::set_$sub"} = sub {
60 $_[0]->set_property ($type, $idx, $_[1]);
61 } unless $ignore_set{$prop};
62 }
63}
64
65# auto-generate most of the API
66
67prop_gen OBJECT_PROP => "cf::object";
68# CFAPI_OBJECT_ANIMATION?
69prop_gen PLAYER_PROP => "cf::object::player";
70
71prop_gen MAP_PROP => "cf::map";
72prop_gen ARCH_PROP => "cf::arch";
73
74# guessed hierarchies
75
76@ext::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
77@ext::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
78
79# we bless all objects into derived classes to force a method lookup
80# within the Safe compartment.
81for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {
82 no strict 'refs';
83 @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 136 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
84} 137}
85 138
86$Event::DIED = sub { 139$Event::DIED = sub {
87 warn "error in event callback: @_"; 140 warn "error in event callback: @_";
88}; 141};
89 142
90my %ext_pkg; 143my %ext_pkg;
91my @exts; 144my @exts;
92my @hook; 145my @hook;
93my %command;
94my %extcmd;
95 146
96sub inject_event { 147=head2 UTILITY FUNCTIONS
97 my $extension = shift; 148
149=over 4
150
151=cut
152
153use JSON::Syck (); # TODO# replace by JSON::PC once working
154
155=item $ref = cf::from_json $json
156
157Converts a JSON string into the corresponding perl data structure.
158
159=cut
160
161sub from_json($) {
162 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
163 JSON::Syck::Load $_[0]
164}
165
166=item $json = cf::to_json $ref
167
168Converts a perl data structure into its JSON representation.
169
170=cut
171
172sub to_json($) {
173 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
174 JSON::Syck::Dump $_[0]
175}
176
177=item $coro = cf::coro { BLOCK }
178
179Creates and returns a new coro. This coro is automcatially being canceled
180when the extension calling this is being unloaded.
181
182=cut
183
184sub coro(&) {
98 my $event_code = shift; 185 my $cb = shift;
99 186
100 my $cb = $hook[$event_code]{$extension} 187 my $coro; $coro = async {
101 or return; 188 eval {
189 $cb->();
190 };
191 warn $@ if $@;
192 };
102 193
103 &$cb 194 $coro->on_destroy (sub {
104} 195 delete $EXT_CORO{$coro+0};
196 });
197 $EXT_CORO{$coro+0} = $coro;
105 198
106sub inject_global_event { 199 $coro
200}
201
202=back
203
204=cut
205
206#############################################################################
207
208=head2 ATTACHABLE OBJECTS
209
210Many objects in crossfire are so-called attachable objects. That means you can
211attach callbacks/event handlers (a collection of which is called an "attachment")
212to it. All such attachable objects support the following methods.
213
214In the following description, CLASS can be any of C<global>, C<object>
215C<player>, C<client> or C<map> (i.e. the attachable objects in
216crossfire+).
217
218=over 4
219
220=item $attachable->attach ($attachment, key => $value...)
221
222=item $attachable->detach ($attachment)
223
224Attach/detach a pre-registered attachment to a specific object and give it
225the specified key/value pairs as arguments.
226
227Example, attach a minesweeper attachment to the given object, making it a
22810x10 minesweeper game:
229
230 $obj->attach (minesweeper => width => 10, height => 10);
231
232=item $bool = $attachable->attached ($name)
233
234Checks wether the named attachment is currently attached to the object.
235
236=item cf::CLASS->attach ...
237
238=item cf::CLASS->detach ...
239
240Define an anonymous attachment and attach it to all objects of the given
241CLASS. See the next function for an explanation of its arguments.
242
243You can attach to global events by using the C<cf::global> class.
244
245Example, log all player logins:
246
247 cf::player->attach (
248 on_login => sub {
249 my ($pl) = @_;
250 ...
251 },
252 );
253
254Example, attach to the jeweler skill:
255
256 cf::object->attach (
257 type => cf::SKILL,
258 subtype => cf::SK_JEWELER,
259 on_use_skill => sub {
260 my ($sk, $ob, $part, $dir, $msg) = @_;
261 ...
262 },
263 );
264
265=item cf::CLASS::attachment $name, ...
266
267Register an attachment by C<$name> through which attachable objects of the
268given CLASS can refer to this attachment.
269
270Some classes such as crossfire maps and objects can specify attachments
271that are attached at load/instantiate time, thus the need for a name.
272
273These calls expect any number of the following handler/hook descriptions:
274
275=over 4
276
277=item prio => $number
278
279Set the priority for all following handlers/hooks (unless overwritten
280by another C<prio> setting). Lower priority handlers get executed
281earlier. The default priority is C<0>, and many built-in handlers are
282registered at priority C<-1000>, so lower priorities should not be used
283unless you know what you are doing.
284
285=item type => $type
286
287(Only for C<< cf::object->attach >> calls), limits the attachment to the
288given type of objects only (the additional parameter C<subtype> can be
289used to further limit to the given subtype).
290
291=item on_I<event> => \&cb
292
293Call the given code reference whenever the named event happens (event is
294something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
295handlers are recognised generally depends on the type of object these
296handlers attach to).
297
298See F<include/eventinc.h> for the full list of events supported, and their
299class.
300
301=item package => package::
302
303Look for sub functions of the name C<< on_I<event> >> in the given
304package and register them. Only handlers for eevents supported by the
305object/class are recognised.
306
307=back
308
309Example, define an attachment called "sockpuppet" that calls the given
310event handler when a monster attacks:
311
312 cf::object::attachment sockpuppet =>
313 on_skill_attack => sub {
314 my ($self, $victim) = @_;
315 ...
316 }
317 }
318
319=item $attachable->valid
320
321Just because you have a perl object does not mean that the corresponding
322C-level object still exists. If you try to access an object that has no
323valid C counterpart anymore you get an exception at runtime. This method
324can be used to test for existence of the C object part without causing an
325exception.
326
327=cut
328
329# the following variables are defined in .xs and must not be re-created
330our @CB_GLOBAL = (); # registry for all global events
331our @CB_ATTACHABLE = (); # registry for all attachables
332our @CB_OBJECT = (); # all objects (should not be used except in emergency)
333our @CB_PLAYER = ();
334our @CB_CLIENT = ();
335our @CB_TYPE = (); # registry for type (cf-object class) based events
336our @CB_MAP = ();
337
338my %attachment;
339
340sub _attach_cb($$$$) {
341 my ($registry, $event, $prio, $cb) = @_;
342
343 use sort 'stable';
344
345 $cb = [$prio, $cb];
346
347 @{$registry->[$event]} = sort
348 { $a->[0] cmp $b->[0] }
349 @{$registry->[$event] || []}, $cb;
350}
351
352# hack
353my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
354
355# attach handles attaching event callbacks
356# the only thing the caller has to do is pass the correct
357# registry (== where the callback attaches to).
358sub _attach {
359 my ($registry, $klass, @arg) = @_;
360
361 my $object_type;
362 my $prio = 0;
363 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
364
365 #TODO: get rid of this hack
366 if ($attachable_klass{$klass}) {
367 %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
368 }
369
370 while (@arg) {
371 my $type = shift @arg;
372
373 if ($type eq "prio") {
374 $prio = shift @arg;
375
376 } elsif ($type eq "type") {
377 $object_type = shift @arg;
378 $registry = $CB_TYPE[$object_type] ||= [];
379
380 } elsif ($type eq "subtype") {
381 defined $object_type or Carp::croak "subtype specified without type";
382 my $object_subtype = shift @arg;
383 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= [];
384
385 } elsif ($type eq "package") {
386 my $pkg = shift @arg;
387
388 while (my ($name, $id) = each %cb_id) {
389 if (my $cb = $pkg->can ($name)) {
390 _attach_cb $registry, $id, $prio, $cb;
391 }
392 }
393
394 } elsif (exists $cb_id{$type}) {
395 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
396
397 } elsif (ref $type) {
398 warn "attaching objects not supported, ignoring.\n";
399
400 } else {
401 shift @arg;
402 warn "attach argument '$type' not supported, ignoring.\n";
403 }
404 }
405}
406
407sub _object_attach {
408 my ($obj, $name, %arg) = @_;
409
410 return if exists $obj->{_attachment}{$name};
411
412 if (my $attach = $attachment{$name}) {
413 my $registry = $obj->registry;
414
415 for (@$attach) {
416 my ($klass, @attach) = @$_;
417 _attach $registry, $klass, @attach;
418 }
419
420 $obj->{$name} = \%arg;
421 } else {
422 warn "object uses attachment '$name' that is not available, postponing.\n";
423 }
424
425 $obj->{_attachment}{$name} = undef;
426}
427
428sub cf::attachable::attach {
429 if (ref $_[0]) {
430 _object_attach @_;
431 } else {
432 _attach shift->_attach_registry, @_;
433 }
434};
435
436# all those should be optimised
437sub cf::attachable::detach {
438 my ($obj, $name) = @_;
439
440 if (ref $obj) {
441 delete $obj->{_attachment}{$name};
442 reattach ($obj);
443 } else {
444 Carp::croak "cannot, currently, detach class attachments";
445 }
446};
447
448sub cf::attachable::attached {
449 my ($obj, $name) = @_;
450
451 exists $obj->{_attachment}{$name}
452}
453
454for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
455 eval "#line " . __LINE__ . " 'cf.pm'
456 sub cf::\L$klass\E::_attach_registry {
457 (\\\@CB_$klass, KLASS_$klass)
458 }
459
460 sub cf::\L$klass\E::attachment {
461 my \$name = shift;
462
463 \$attachment{\$name} = [[KLASS_$klass, \@_]];
464 }
465 ";
466 die if $@;
467}
468
469our $override;
470our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
471
472sub override {
473 $override = 1;
474 @invoke_results = ();
475}
476
477sub do_invoke {
107 my $event = shift; 478 my $event = shift;
479 my $callbacks = shift;
108 480
109 my $cb = $hook[$event] 481 @invoke_results = ();
110 or return;
111 482
112 List::Util::max map &$_, values %$cb 483 local $override;
113}
114 484
115sub inject_command { 485 for (@$callbacks) {
116 my ($name, $obj, $params) = @_; 486 eval { &{$_->[1]} };
117 487
118 for my $cmd (@{ $command{$name} }) { 488 if ($@) {
119 $cmd->[1]->($obj, $params); 489 warn "$@";
490 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
491 override;
492 }
493
494 return 1 if $override;
495 }
496
497 0
498}
499
500=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)
501
502=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
503
504Generate an object-specific event with the given arguments.
505
506This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
507removed in future versions), and there is no public API to access override
508results (if you must, access C<@cf::invoke_results> directly).
509
510=back
511
512=cut
513
514#############################################################################
515# object support
516
517sub reattach {
518 # basically do the same as instantiate, without calling instantiate
519 my ($obj) = @_;
520
521 my $registry = $obj->registry;
522
523 @$registry = ();
524
525 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
526
527 for my $name (keys %{ $obj->{_attachment} || {} }) {
528 if (my $attach = $attachment{$name}) {
529 for (@$attach) {
530 my ($klass, @attach) = @$_;
531 _attach $registry, $klass, @attach;
532 }
533 } else {
534 warn "object uses attachment '$name' that is not available, postponing.\n";
535 }
536 }
537}
538
539cf::attachable->attach (
540 prio => -1000000,
541 on_instantiate => sub {
542 my ($obj, $data) = @_;
543
544 $data = from_json $data;
545
546 for (@$data) {
547 my ($name, $args) = @$_;
548
549 $obj->attach ($name, %{$args || {} });
550 }
120 } 551 },
552 on_reattach => \&reattach,
553 on_clone => sub {
554 my ($src, $dst) = @_;
121 555
122 -1 556 @{$dst->registry} = @{$src->registry};
557
558 %$dst = %$src;
559
560 %{$dst->{_attachment}} = %{$src->{_attachment}}
561 if exists $src->{_attachment};
562 },
563);
564
565sub object_freezer_save {
566 my ($filename, $rdata, $objs) = @_;
567
568 if (length $$rdata) {
569 warn sprintf "saving %s (%d,%d)\n",
570 $filename, length $$rdata, scalar @$objs;
571
572 if (open my $fh, ">:raw", "$filename~") {
573 chmod SAVE_MODE, $fh;
574 syswrite $fh, $$rdata;
575 close $fh;
576
577 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
578 chmod SAVE_MODE, $fh;
579 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
580 close $fh;
581 rename "$filename.pst~", "$filename.pst";
582 } else {
583 unlink "$filename.pst";
584 }
585
586 rename "$filename~", $filename;
587 } else {
588 warn "FATAL: $filename~: $!\n";
589 }
590 } else {
591 unlink $filename;
592 unlink "$filename.pst";
593 }
123} 594}
595
596sub object_freezer_as_string {
597 my ($rdata, $objs) = @_;
598
599 use Data::Dumper;
600
601 $$rdata . Dumper $objs
602}
603
604sub object_thawer_load {
605 my ($filename) = @_;
606
607 local $/;
608
609 my $av;
610
611 #TODO: use sysread etc.
612 if (open my $data, "<:raw:perlio", $filename) {
613 $data = <$data>;
614 if (open my $pst, "<:raw:perlio", "$filename.pst") {
615 $av = eval { (Storable::thaw <$pst>)->{objs} };
616 }
617 return ($data, $av);
618 }
619
620 ()
621}
622
623#############################################################################
624# command handling &c
625
626=item cf::register_command $name => \&callback($ob,$args);
627
628Register a callback for execution when the client sends the user command
629$name.
630
631=cut
124 632
125sub register_command { 633sub register_command {
126 my ($name, $time, $cb) = @_; 634 my ($name, $cb) = @_;
127 635
128 my $caller = caller; 636 my $caller = caller;
129 #warn "registering command '$name/$time' to '$caller'"; 637 #warn "registering command '$name/$time' to '$caller'";
130 638
131 push @{ $command{$name} }, [$time, $cb, $caller]; 639 push @{ $COMMAND{$name} }, [$caller, $cb];
132 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
133} 640}
641
642=item cf::register_extcmd $name => \&callback($pl,$packet);
643
644Register a callbackf ro execution when the client sends an extcmd packet.
645
646If the callback returns something, it is sent back as if reply was being
647called.
648
649=cut
134 650
135sub register_extcmd { 651sub register_extcmd {
136 my ($name, $cb) = @_; 652 my ($name, $cb) = @_;
137 653
138 my $caller = caller; 654 my $caller = caller;
139 #warn "registering extcmd '$name' to '$caller'"; 655 #warn "registering extcmd '$name' to '$caller'";
140 656
141 $extcmd{$name} = [$cb, $caller]; 657 $EXTCMD{$name} = [$cb, $caller];
142} 658}
659
660cf::player->attach (
661 on_command => sub {
662 my ($pl, $name, $params) = @_;
663
664 my $cb = $COMMAND{$name}
665 or return;
666
667 for my $cmd (@$cb) {
668 $cmd->[1]->($pl->ob, $params);
669 }
670
671 cf::override;
672 },
673 on_extcmd => sub {
674 my ($pl, $buf) = @_;
675
676 my $msg = eval { from_json $buf };
677
678 if (ref $msg) {
679 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
680 if (my %reply = $cb->[0]->($pl, $msg)) {
681 $pl->ext_reply ($msg->{msgid}, %reply);
682 }
683 }
684 } else {
685 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
686 }
687
688 cf::override;
689 },
690);
143 691
144sub register { 692sub register {
145 my ($base, $pkg) = @_; 693 my ($base, $pkg) = @_;
146 694
147 for my $idx (0 .. $#PLUGIN_EVENT) { 695 #TODO
148 if (my $ref = $pkg->can ("on_$PLUGIN_EVENT[$idx]")) {
149 #warn "registering $PLUGIN_EVENT[$idx] hook to '$pkg'\n";
150 $hook[$idx]{$base} = $ref;
151 }
152 }
153} 696}
154 697
155sub load_extension { 698sub load_extension {
156 my ($path) = @_; 699 my ($path) = @_;
157 700
158 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 701 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
159 my $base = $1; 702 my $base = $1;
160 my $pkg = $1; 703 my $pkg = $1;
161 $pkg =~ s/[^[:word:]]/_/g; 704 $pkg =~ s/[^[:word:]]/_/g;
162 $pkg = "cf::ext::$pkg"; 705 $pkg = "ext::$pkg";
163 706
164 warn "loading '$path' into '$pkg'\n"; 707 warn "loading '$path' into '$pkg'\n";
165 708
166 open my $fh, "<:utf8", $path 709 open my $fh, "<:utf8", $path
167 or die "$path: $!"; 710 or die "$path: $!";
… …
171 . "#line 1 \"$path\"\n{\n" 714 . "#line 1 \"$path\"\n{\n"
172 . (do { local $/; <$fh> }) 715 . (do { local $/; <$fh> })
173 . "\n};\n1"; 716 . "\n};\n1";
174 717
175 eval $source 718 eval $source
176 or die "$path: $@"; 719 or die $@ ? "$path: $@\n"
720 : "extension disabled.\n";
177 721
178 push @exts, $pkg; 722 push @exts, $pkg;
179 $ext_pkg{$base} = $pkg; 723 $ext_pkg{$base} = $pkg;
180 724
181# no strict 'refs'; 725# no strict 'refs';
… …
188 my ($pkg) = @_; 732 my ($pkg) = @_;
189 733
190 warn "removing extension $pkg\n"; 734 warn "removing extension $pkg\n";
191 735
192 # remove hooks 736 # remove hooks
737 #TODO
193 for my $idx (0 .. $#PLUGIN_EVENT) { 738# for my $idx (0 .. $#PLUGIN_EVENT) {
194 delete $hook[$idx]{$pkg}; 739# delete $hook[$idx]{$pkg};
195 } 740# }
196 741
197 # remove commands 742 # remove commands
198 for my $name (keys %command) { 743 for my $name (keys %COMMAND) {
199 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 744 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
200 745
201 if (@cb) { 746 if (@cb) {
202 $command{$name} = \@cb; 747 $COMMAND{$name} = \@cb;
203 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
204 } else { 748 } else {
205 delete $command{$name};
206 delete $COMMAND{"$name\000"}; 749 delete $COMMAND{$name};
207 } 750 }
208 } 751 }
209 752
210 # remove extcmds 753 # remove extcmds
211 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 754 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
212 delete $extcmd{$name}; 755 delete $EXTCMD{$name};
213 } 756 }
214 757
215 if (my $cb = $pkg->can ("on_unload")) { 758 if (my $cb = $pkg->can ("unload")) {
216 eval { 759 eval {
217 $cb->($pkg); 760 $cb->($pkg);
218 1 761 1
219 } or warn "$pkg unloaded, but with errors: $@"; 762 } or warn "$pkg unloaded, but with errors: $@";
220 } 763 }
221 764
222 Symbol::delete_package $pkg; 765 Symbol::delete_package $pkg;
223} 766}
224 767
225sub load_extensions { 768sub load_extensions {
226 my $LIBDIR = maps_directory "perl";
227
228 for my $ext (<$LIBDIR/*.ext>) { 769 for my $ext (<$LIBDIR/*.ext>) {
229 next unless -r $ext; 770 next unless -r $ext;
230 eval { 771 eval {
231 load_extension $ext; 772 load_extension $ext;
232 1 773 1
233 } or warn "$ext not loaded: $@"; 774 } or warn "$ext not loaded: $@";
234 } 775 }
235} 776}
236 777
237sub _perl_reload(&) {
238 my ($msg) = @_;
239
240 $msg->("reloading...");
241
242 eval {
243 # 1. cancel all watchers
244 $_->cancel for Event::all_watchers;
245
246 # 2. unload all extensions
247 for (@exts) {
248 $msg->("unloading <$_>");
249 unload_extension $_;
250 }
251
252 # 3. unload all modules loaded from $LIBDIR
253 while (my ($k, $v) = each %INC) {
254 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
255
256 $msg->("removing <$k>");
257 delete $INC{$k};
258
259 $k =~ s/\.pm$//;
260 $k =~ s/\//::/g;
261
262 if (my $cb = $k->can ("unload_module")) {
263 $cb->();
264 }
265
266 Symbol::delete_package $k;
267 }
268
269 # 4. get rid of ext::, as good as possible
270 Symbol::delete_package "ext::$_"
271 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);
272
273 # 5. remove register_script_function callbacks
274 # TODO
275
276 # 6. unload cf.pm "a bit"
277 delete $INC{"cf.pm"};
278
279 # don't, removes xs symbols, too
280 #Symbol::delete_package __PACKAGE__;
281
282 # 7. reload cf.pm
283 $msg->("reloading cf.pm");
284 require cf;
285 };
286 $msg->($@) if $@;
287
288 $msg->("reloaded");
289};
290
291sub perl_reload() {
292 _perl_reload {
293 warn $_[0];
294 print "$_[0]\n";
295 };
296}
297
298register_command "perl-reload", 0, sub {
299 my ($who, $arg) = @_;
300
301 if ($who->flag (FLAG_WIZ)) {
302 _perl_reload {
303 warn $_[0];
304 $who->message ($_[0]);
305 };
306 }
307};
308
309#############################################################################
310# utility functions
311
312use JSON::Syck (); # TODO# replace by JSON::PC once working
313
314sub from_json($) {
315 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
316 JSON::Syck::Load $_[0]
317}
318
319sub to_json($) {
320 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
321 JSON::Syck::Dump $_[0]
322}
323
324#############################################################################
325# extcmd framework, basically convert ext <msg>
326# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
327
328sub on_extcmd {
329 my ($pl, $buf) = @_;
330
331 my $msg = eval { from_json $buf };
332
333 if (ref $msg) {
334 if (my $cb = $extcmd{$msg->{msgtype}}) {
335 if (my %reply = $cb->[0]->($pl, $msg)) {
336 $pl->ext_reply ($msg->{msgid}, %reply);
337 }
338 }
339 } else {
340 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
341 }
342
343 1
344}
345
346############################################################################# 778#############################################################################
347# load/save/clean perl data associated with a map 779# load/save/clean perl data associated with a map
348 780
349*on_mapclean = sub { 781*cf::mapsupport::on_clean = sub {
350 my ($map) = @_; 782 my ($map) = @_;
351 783
352 my $path = $map->tmpname; 784 my $path = $map->tmpname;
353 defined $path or return; 785 defined $path or return;
354 786
355 unlink "$path.cfperl"; 787 unlink "$path.pst";
356}; 788};
357 789
358*on_mapin = 790cf::map->attach (prio => -10000, package => cf::mapsupport::);
359*on_mapload = sub {
360 my ($map) = @_;
361
362 my $path = $map->tmpname;
363 $path = $map->path unless defined $path;
364
365 open my $fh, "<:raw", "$path.cfperl"
366 or return; # no perl data
367
368 my $data = Storable::thaw do { local $/; <$fh> };
369
370 $data->{version} <= 1
371 or return; # too new
372
373 $map->_set_obs ($data->{obs});
374};
375
376*on_mapout = sub {
377 my ($map) = @_;
378
379 my $path = $map->tmpname;
380 $path = $map->path unless defined $path;
381
382 my $obs = $map->_get_obs;
383
384 if (defined $obs) {
385 open my $fh, ">:raw", "$path.cfperl"
386 or die "$path.cfperl: $!";
387
388 stat $path;
389
390 print $fh Storable::nfreeze {
391 size => (stat _)[7],
392 time => (stat _)[9],
393 version => 1,
394 obs => $obs,
395 };
396
397 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
398 } else {
399 unlink "$path.cfperl";
400 }
401};
402 791
403############################################################################# 792#############################################################################
404# load/save perl data associated with player->ob objects 793# load/save perl data associated with player->ob objects
405 794
406sub all_objects(@) { 795sub all_objects(@) {
407 @_, map all_objects ($_->inv), @_ 796 @_, map all_objects ($_->inv), @_
408} 797}
409 798
410*on_player_load = sub { 799# TODO: compatibility cruft, remove when no longer needed
800cf::player->attach (
801 on_load => sub {
411 my ($ob, $path) = @_; 802 my ($pl, $path) = @_;
412 803
413 for my $o (all_objects $ob) { 804 for my $o (all_objects $pl->ob) {
414 if (my $value = $o->get_ob_key_value ("_perl_data")) { 805 if (my $value = $o->get_ob_key_value ("_perl_data")) {
415 $o->set_ob_key_value ("_perl_data"); 806 $o->set_ob_key_value ("_perl_data");
416 807
417 %$o = %{ Storable::thaw pack "H*", $value }; 808 %$o = %{ Storable::thaw pack "H*", $value };
418 } 809 }
810 }
419 } 811 },
420}; 812);
421
422*on_player_save = sub {
423 my ($ob, $path) = @_;
424
425 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
426 for grep %$_, all_objects $ob;
427};
428 813
429############################################################################# 814#############################################################################
430# core extensions - in perl 815
816=head2 CORE EXTENSIONS
817
818Functions and methods that extend core crossfire objects.
819
820=head3 cf::player
821
822=over 4
431 823
432=item cf::player::exists $login 824=item cf::player::exists $login
433 825
434Returns true when the given account exists. 826Returns true when the given account exists.
435 827
… …
438sub cf::player::exists($) { 830sub cf::player::exists($) {
439 cf::player::find $_[0] 831 cf::player::find $_[0]
440 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 832 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
441} 833}
442 834
835=item $player->ext_reply ($msgid, $msgtype, %msg)
836
837Sends an ext reply to the player.
838
839=cut
840
841sub cf::player::ext_reply($$$%) {
842 my ($self, $id, %msg) = @_;
843
844 $msg{msgid} = $id;
845
846 $self->send ("ext " . to_json \%msg);
847}
848
849=back
850
851=head3 cf::object::player
852
853=over 4
854
443=item $player->reply ($npc, $msg[, $flags]) 855=item $player_object->reply ($npc, $msg[, $flags])
444 856
445Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 857Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
446can be C<undef>. Does the right thing when the player is currently in a 858can be C<undef>. Does the right thing when the player is currently in a
447dialogue with the given NPC character. 859dialogue with the given NPC character.
448 860
449=cut 861=cut
450 862
451# rough implementation of a future "reply" method that works 863# rough implementation of a future "reply" method that works
452# with dialog boxes. 864# with dialog boxes.
865#TODO: the first argument must go, split into a $npc->reply_to ( method
453sub cf::object::player::reply($$$;$) { 866sub cf::object::player::reply($$$;$) {
454 my ($self, $npc, $msg, $flags) = @_; 867 my ($self, $npc, $msg, $flags) = @_;
455 868
456 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 869 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
457 870
… …
461 $msg = $npc->name . " says: $msg" if $npc; 874 $msg = $npc->name . " says: $msg" if $npc;
462 $self->message ($msg, $flags); 875 $self->message ($msg, $flags);
463 } 876 }
464} 877}
465 878
466=item $player->ext_reply ($msgid, $msgtype, %msg) 879=item $player_object->may ("access")
467 880
468Sends an ext reply to the player. 881Returns wether the given player is authorized to access resource "access"
882(e.g. "command_wizcast").
469 883
470=cut 884=cut
471 885
472sub cf::player::ext_reply($$$%) { 886sub cf::object::player::may {
887 my ($self, $access) = @_;
888
889 $self->flag (cf::FLAG_WIZ) ||
890 (ref $cf::CFG{"may_$access"}
891 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
892 : $cf::CFG{"may_$access"})
893}
894
895=head3 cf::client
896
897=over 4
898
899=item $client->send_drawinfo ($text, $flags)
900
901Sends a drawinfo packet to the client. Circumvents output buffering so
902should not be used under normal circumstances.
903
904=cut
905
906sub cf::client::send_drawinfo {
907 my ($self, $text, $flags) = @_;
908
909 utf8::encode $text;
910 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text);
911}
912
913
914=item $success = $client->query ($flags, "text", \&cb)
915
916Queues a query to the client, calling the given callback with
917the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
918C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
919
920Queries can fail, so check the return code. Or don't, as queries will become
921reliable at some point in the future.
922
923=cut
924
925sub cf::client::query {
926 my ($self, $flags, $text, $cb) = @_;
927
928 return unless $self->state == ST_PLAYING
929 || $self->state == ST_SETUP
930 || $self->state == ST_CUSTOM;
931
932 $self->state (ST_CUSTOM);
933
934 utf8::encode $text;
935 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
936
937 $self->send_packet ($self->{query_queue}[0][0])
938 if @{ $self->{query_queue} } == 1;
939}
940
941cf::client->attach (
942 on_reply => sub {
943 my ($ns, $msg) = @_;
944
945 # this weird shuffling is so that direct followup queries
946 # get handled first
947 my $queue = delete $ns->{query_queue};
948
949 (shift @$queue)->[1]->($msg);
950
951 push @{ $ns->{query_queue} }, @$queue;
952
953 if (@{ $ns->{query_queue} } == @$queue) {
954 if (@$queue) {
955 $ns->send_packet ($ns->{query_queue}[0][0]);
956 } else {
957 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
958 }
959 }
960 },
961);
962
963=item $client->coro (\&cb)
964
965Create a new coroutine, running the specified callback. The coroutine will
966be automatically cancelled when the client gets destroyed (e.g. on logout,
967or loss of connection).
968
969=cut
970
971sub cf::client::coro {
473 my ($self, $id, %msg) = @_; 972 my ($self, $cb) = @_;
474 973
475 $msg{msgid} = $id; 974 my $coro; $coro = async {
975 eval {
976 $cb->();
977 };
978 warn $@ if $@;
979 };
476 980
477 $self->send ("ext " . to_json \%msg); 981 $coro->on_destroy (sub {
478} 982 delete $self->{_coro}{$coro+0};
983 });
479 984
480############################################################################# 985 $self->{_coro}{$coro+0} = $coro;
481# map scripting support
482 986
987 $coro
988}
989
990cf::client->attach (
991 on_destroy => sub {
992 my ($ns) = @_;
993
994 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
995 },
996);
997
998=back
999
1000
1001=head2 SAFE SCRIPTING
1002
1003Functions that provide a safe environment to compile and execute
1004snippets of perl code without them endangering the safety of the server
1005itself. Looping constructs, I/O operators and other built-in functionality
1006is not available in the safe scripting environment, and the number of
1007functions and methods that can be called is greatly reduced.
1008
1009=cut
1010
483our $safe = new Safe "ext"; 1011our $safe = new Safe "safe";
484our $safe_hole = new Safe::Hole; 1012our $safe_hole = new Safe::Hole;
485 1013
486$SIG{FPE} = 'IGNORE'; 1014$SIG{FPE} = 'IGNORE';
487 1015
488$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 1016$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
489 1017
490# here we export the classes and methods available to script code 1018# here we export the classes and methods available to script code
491 1019
1020=pod
1021
1022The following fucntions and emthods are available within a safe environment:
1023
1024 cf::object contr pay_amount pay_player map
1025 cf::object::player player
1026 cf::player peaceful
1027 cf::map trigger
1028
1029=cut
1030
492for ( 1031for (
493 ["cf::object" => qw(contr pay_amount pay_player)], 1032 ["cf::object" => qw(contr pay_amount pay_player map)],
494 ["cf::object::player" => qw(player)], 1033 ["cf::object::player" => qw(player)],
495 ["cf::player" => qw(peaceful)], 1034 ["cf::player" => qw(peaceful)],
1035 ["cf::map" => qw(trigger)],
496) { 1036) {
497 no strict 'refs'; 1037 no strict 'refs';
498 my ($pkg, @funs) = @$_; 1038 my ($pkg, @funs) = @$_;
499 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 1039 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
500 for @funs; 1040 for @funs;
501} 1041}
1042
1043=over 4
1044
1045=item @retval = safe_eval $code, [var => value, ...]
1046
1047Compiled and executes the given perl code snippet. additional var/value
1048pairs result in temporary local (my) scalar variables of the given name
1049that are available in the code snippet. Example:
1050
1051 my $five = safe_eval '$first + $second', first => 1, second => 4;
1052
1053=cut
502 1054
503sub safe_eval($;@) { 1055sub safe_eval($;@) {
504 my ($code, %vars) = @_; 1056 my ($code, %vars) = @_;
505 1057
506 my $qcode = $code; 1058 my $qcode = $code;
507 $qcode =~ s/"/‟/g; # not allowed in #line filenames 1059 $qcode =~ s/"/‟/g; # not allowed in #line filenames
508 $qcode =~ s/\n/\\n/g; 1060 $qcode =~ s/\n/\\n/g;
509 1061
510 local $_; 1062 local $_;
511 local @ext::cf::_safe_eval_args = values %vars; 1063 local @safe::cf::_safe_eval_args = values %vars;
512 1064
513 $code = 1065 my $eval =
514 "do {\n" 1066 "do {\n"
515 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 1067 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
516 . "#line 0 \"{$qcode}\"\n" 1068 . "#line 0 \"{$qcode}\"\n"
517 . $code 1069 . $code
518 . "\n}" 1070 . "\n}"
519 ; 1071 ;
520 1072
521 sub_generation_inc; 1073 sub_generation_inc;
522 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 1074 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
523 sub_generation_inc; 1075 sub_generation_inc;
524 1076
1077 if ($@) {
1078 warn "$@";
1079 warn "while executing safe code '$code'\n";
1080 warn "with arguments " . (join " ", %vars) . "\n";
1081 }
1082
525 wantarray ? @res : $res[0] 1083 wantarray ? @res : $res[0]
526} 1084}
1085
1086=item cf::register_script_function $function => $cb
1087
1088Register a function that can be called from within map/npc scripts. The
1089function should be reasonably secure and should be put into a package name
1090like the extension.
1091
1092Example: register a function that gets called whenever a map script calls
1093C<rent::overview>, as used by the C<rent> extension.
1094
1095 cf::register_script_function "rent::overview" => sub {
1096 ...
1097 };
1098
1099=cut
527 1100
528sub register_script_function { 1101sub register_script_function {
529 my ($fun, $cb) = @_; 1102 my ($fun, $cb) = @_;
530 1103
531 no strict 'refs'; 1104 no strict 'refs';
532 *{"ext::$fun"} = $safe_hole->wrap ($cb); 1105 *{"safe::$fun"} = $safe_hole->wrap ($cb);
1106}
1107
1108=back
1109
1110=cut
1111
1112#############################################################################
1113
1114=head2 EXTENSION DATABASE SUPPORT
1115
1116Crossfire maintains a very simple database for extension use. It can
1117currently store anything that can be serialised using Storable, which
1118excludes objects.
1119
1120The parameter C<$family> should best start with the name of the extension
1121using it, it should be unique.
1122
1123=over 4
1124
1125=item $hashref = cf::db_get $family
1126
1127Return a hashref for use by the extension C<$family>, which can be
1128modified. After modifications, you have to call C<cf::db_dirty> or
1129C<cf::db_sync>.
1130
1131=item $value = cf::db_get $family => $key
1132
1133Returns a single value from the database
1134
1135=item cf::db_put $family => $hashref
1136
1137Stores the given family hashref into the database. Updates are delayed, if
1138you want the data to be synced to disk immediately, use C<cf::db_sync>.
1139
1140=item cf::db_put $family => $key => $value
1141
1142Stores the given C<$value> in the family hash. Updates are delayed, if you
1143want the data to be synced to disk immediately, use C<cf::db_sync>.
1144
1145=item cf::db_dirty
1146
1147Marks the database as dirty, to be updated at a later time.
1148
1149=item cf::db_sync
1150
1151Immediately write the database to disk I<if it is dirty>.
1152
1153=cut
1154
1155our $DB;
1156
1157{
1158 my $path = cf::localdir . "/database.pst";
1159
1160 sub db_load() {
1161 warn "loading database $path\n";#d# remove later
1162 $DB = stat $path ? Storable::retrieve $path : { };
1163 }
1164
1165 my $pid;
1166
1167 sub db_save() {
1168 warn "saving database $path\n";#d# remove later
1169 waitpid $pid, 0 if $pid;
1170 if (0 == ($pid = fork)) {
1171 $DB->{_meta}{version} = 1;
1172 Storable::nstore $DB, "$path~";
1173 rename "$path~", $path;
1174 cf::_exit 0 if defined $pid;
1175 }
1176 }
1177
1178 my $dirty;
1179
1180 sub db_sync() {
1181 db_save if $dirty;
1182 undef $dirty;
1183 }
1184
1185 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1186 db_sync;
1187 });
1188
1189 sub db_dirty() {
1190 $dirty = 1;
1191 $idle->start;
1192 }
1193
1194 sub db_get($;$) {
1195 @_ >= 2
1196 ? $DB->{$_[0]}{$_[1]}
1197 : ($DB->{$_[0]} ||= { })
1198 }
1199
1200 sub db_put($$;$) {
1201 if (@_ >= 3) {
1202 $DB->{$_[0]}{$_[1]} = $_[2];
1203 } else {
1204 $DB->{$_[0]} = $_[1];
1205 }
1206 db_dirty;
1207 }
1208
1209 cf::global->attach (
1210 prio => 10000,
1211 on_cleanup => sub {
1212 db_sync;
1213 },
1214 );
533} 1215}
534 1216
535############################################################################# 1217#############################################################################
536# the server's main() 1218# the server's main()
537 1219
538sub run { 1220sub cfg_load {
1221 open my $fh, "<:utf8", cf::confdir . "/config"
1222 or return;
1223
1224 local $/;
1225 *CFG = YAML::Syck::Load <$fh>;
1226}
1227
1228sub main {
1229 cfg_load;
1230 db_load;
1231 load_extensions;
539 Event::loop; 1232 Event::loop;
540} 1233}
541 1234
542############################################################################# 1235#############################################################################
543# initialisation 1236# initialisation
544 1237
1238sub _perl_reload() {
1239 warn "reloading...";
1240
1241 eval {
1242 local $FREEZE = 1;
1243
1244 cf::emergency_save;
1245
1246 # cancel all watchers
1247 for (Event::all_watchers) {
1248 $_->cancel if $_->data & WF_AUTOCANCEL;
1249 }
1250
1251 # cancel all extension coros
1252 $_->cancel for values %EXT_CORO;
1253 %EXT_CORO = ();
1254
1255 # unload all extensions
1256 for (@exts) {
1257 warn "unloading <$_>";
1258 unload_extension $_;
1259 }
1260
1261 # unload all modules loaded from $LIBDIR
1262 while (my ($k, $v) = each %INC) {
1263 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1264
1265 warn "removing <$k>";
1266 delete $INC{$k};
1267
1268 $k =~ s/\.pm$//;
1269 $k =~ s/\//::/g;
1270
1271 if (my $cb = $k->can ("unload_module")) {
1272 $cb->();
1273 }
1274
1275 Symbol::delete_package $k;
1276 }
1277
1278 # sync database to disk
1279 cf::db_sync;
1280 IO::AIO::flush;
1281
1282 # get rid of safe::, as good as possible
1283 Symbol::delete_package "safe::$_"
1284 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1285
1286 # remove register_script_function callbacks
1287 # TODO
1288
1289 # unload cf.pm "a bit"
1290 delete $INC{"cf.pm"};
1291
1292 # don't, removes xs symbols, too,
1293 # and global variables created in xs
1294 #Symbol::delete_package __PACKAGE__;
1295
1296 # reload cf.pm
1297 warn "reloading cf.pm";
1298 require cf;
1299 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1300
1301 # load config and database again
1302 cf::cfg_load;
1303 cf::db_load;
1304
1305 # load extensions
1306 warn "load extensions";
1307 cf::load_extensions;
1308
1309 # reattach attachments to objects
1310 warn "reattach";
1311 _global_reattach;
1312 };
1313 warn $@ if $@;
1314
1315 warn "reloaded";
1316};
1317
1318sub perl_reload() {
1319 _perl_reload;
1320}
1321
545register "<global>", __PACKAGE__; 1322register "<global>", __PACKAGE__;
546 1323
1324register_command "perl-reload" => sub {
1325 my ($who, $arg) = @_;
1326
1327 if ($who->flag (FLAG_WIZ)) {
1328 $who->message ("reloading...");
1329 _perl_reload;
1330 }
1331};
1332
547unshift @INC, $LIBDIR; 1333unshift @INC, $LIBDIR;
548 1334
549load_extensions;
550
551$TICK_WATCHER = Event->timer ( 1335$TICK_WATCHER = Event->timer (
552 prio => 1, 1336 prio => 0,
553 at => $NEXT_TICK || 1, 1337 at => $NEXT_TICK || $TICK,
1338 data => WF_AUTOCANCEL,
554 cb => sub { 1339 cb => sub {
1340 unless ($FREEZE) {
555 cf::server_tick; # one server iteration 1341 cf::server_tick; # one server iteration
1342 $RUNTIME += $TICK;
1343 }
556 1344
557 my $NOW = Event::time;
558 $NEXT_TICK += $TICK; 1345 $NEXT_TICK += $TICK;
559 1346
560 # if we are delayed by four ticks, skip them all 1347 # if we are delayed by four ticks or more, skip them all
561 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1348 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
562 1349
563 $TICK_WATCHER->at ($NEXT_TICK); 1350 $TICK_WATCHER->at ($NEXT_TICK);
564 $TICK_WATCHER->start; 1351 $TICK_WATCHER->start;
565 }, 1352 },
566); 1353);
567 1354
1355IO::AIO::max_poll_time $TICK * 0.2;
1356
1357Event->io (fd => IO::AIO::poll_fileno,
1358 poll => 'r',
1359 prio => 5,
1360 data => WF_AUTOCANCEL,
1361 cb => \&IO::AIO::poll_cb);
1362
1363# we must not ever block the main coroutine
1364$Coro::idle = sub {
1365 #Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#
1366 warn "FATAL: Coro::idle was called, major BUG\n";
1367 (Coro::unblock_sub {
1368 Event::one_event;
1369 })->();
1370};
1371
5681 13721
569 1373

Diff Legend

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