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.35 by root, Thu Aug 24 13:35:48 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 %PROP_TYPE; 37our $LIBDIR = datadir . "/ext";
19our %PROP_IDX;
20our $LIBDIR = maps_directory "perl";
21 38
22our $TICK = MAX_TIME * 1e-6; 39our $TICK = MAX_TIME * 1e-6;
23our $TICK_WATCHER; 40our $TICK_WATCHER;
24our $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
25 106
26BEGIN { 107BEGIN {
27 @EVENT = map lc, @EVENT;
28
29 *CORE::GLOBAL::warn = sub { 108 *CORE::GLOBAL::warn = sub {
30 my $msg = join "", @_; 109 my $msg = join "", @_;
110 utf8::encode $msg;
111
31 $msg .= "\n" 112 $msg .= "\n"
32 unless $msg =~ /\n$/; 113 unless $msg =~ /\n$/;
33 114
34 print STDERR "cfperl: $msg";
35 LOG llevError, "cfperl: $msg"; 115 LOG llevError, "cfperl: $msg";
36 }; 116 };
37} 117}
38 118
39my %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';
40 125
41# generate property mutators 126# we bless all objects into (empty) derived classes to force a method lookup
42sub prop_gen { 127# within the Safe compartment.
43 my ($prefix, $class) = @_; 128for my $pkg (qw(
44 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)) {
45 no strict 'refs'; 135 no strict 'refs';
46
47 for my $prop (keys %PROP_TYPE) {
48 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
49 my $sub = lc $1;
50
51 my $type = $PROP_TYPE{$prop};
52 my $idx = $PROP_IDX {$prop};
53
54 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
55 $_[0]->get_property ($type, $idx)
56 };
57
58 *{"$class\::set_$sub"} = sub {
59 $_[0]->set_property ($type, $idx, $_[1]);
60 } unless $ignore_set{$prop};
61 }
62}
63
64# auto-generate most of the API
65
66prop_gen OBJECT_PROP => "cf::object";
67# CFAPI_OBJECT_ANIMATION?
68prop_gen PLAYER_PROP => "cf::object::player";
69
70prop_gen MAP_PROP => "cf::map";
71prop_gen ARCH_PROP => "cf::arch";
72
73# guessed hierarchies
74
75@ext::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
76@ext::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
77
78# we bless all objects into derived classes to force a method lookup
79# within the Safe compartment.
80for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {
81 no strict 'refs';
82 @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 136 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
83} 137}
84 138
85$Event::DIED = sub { 139$Event::DIED = sub {
86 warn "error in event callback: @_"; 140 warn "error in event callback: @_";
87}; 141};
88 142
89my %ext_pkg; 143my %ext_pkg;
90my @exts; 144my @exts;
91my @hook; 145my @hook;
92my %command;
93my %extcmd;
94 146
95sub inject_event { 147=head2 UTILITY FUNCTIONS
96 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(&) {
97 my $event_code = shift; 185 my $cb = shift;
98 186
99 my $cb = $hook[$event_code]{$extension} 187 my $coro; $coro = async {
100 or return; 188 eval {
189 $cb->();
190 };
191 warn $@ if $@;
192 };
101 193
102 &$cb 194 $coro->on_destroy (sub {
103} 195 delete $EXT_CORO{$coro+0};
196 });
197 $EXT_CORO{$coro+0} = $coro;
104 198
105sub 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 {
106 my $event = shift; 478 my $event = shift;
479 my $callbacks = shift;
107 480
108 my $cb = $hook[$event] 481 @invoke_results = ();
109 or return;
110 482
111 List::Util::max map &$_, values %$cb 483 local $override;
112}
113 484
114sub inject_command { 485 for (@$callbacks) {
115 my ($name, $obj, $params) = @_; 486 eval { &{$_->[1]} };
116 487
117 for my $cmd (@{ $command{$name} }) { 488 if ($@) {
118 $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 }
119 } 551 },
552 on_reattach => \&reattach,
553 on_clone => sub {
554 my ($src, $dst) = @_;
120 555
121 -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 }
122} 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
123 632
124sub register_command { 633sub register_command {
125 my ($name, $time, $cb) = @_; 634 my ($name, $cb) = @_;
126 635
127 my $caller = caller; 636 my $caller = caller;
128 #warn "registering command '$name/$time' to '$caller'"; 637 #warn "registering command '$name/$time' to '$caller'";
129 638
130 push @{ $command{$name} }, [$time, $cb, $caller]; 639 push @{ $COMMAND{$name} }, [$caller, $cb];
131 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
132} 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
133 650
134sub register_extcmd { 651sub register_extcmd {
135 my ($name, $cb) = @_; 652 my ($name, $cb) = @_;
136 653
137 my $caller = caller; 654 my $caller = caller;
138 #warn "registering extcmd '$name' to '$caller'"; 655 #warn "registering extcmd '$name' to '$caller'";
139 656
140 $extcmd{$name} = [$cb, $caller]; 657 $EXTCMD{$name} = [$cb, $caller];
141} 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);
142 691
143sub register { 692sub register {
144 my ($base, $pkg) = @_; 693 my ($base, $pkg) = @_;
145 694
146 for my $idx (0 .. $#EVENT) { 695 #TODO
147 if (my $ref = $pkg->can ("on_$EVENT[$idx]")) {
148 #warn "registering $EVENT[$idx] hook to '$pkg'\n";
149 $hook[$idx]{$base} = $ref;
150 }
151 }
152} 696}
153 697
154sub load_extension { 698sub load_extension {
155 my ($path) = @_; 699 my ($path) = @_;
156 700
157 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 701 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
158 my $base = $1; 702 my $base = $1;
159 my $pkg = $1; 703 my $pkg = $1;
160 $pkg =~ s/[^[:word:]]/_/g; 704 $pkg =~ s/[^[:word:]]/_/g;
161 $pkg = "cf::ext::$pkg"; 705 $pkg = "ext::$pkg";
162 706
163 warn "loading '$path' into '$pkg'\n"; 707 warn "loading '$path' into '$pkg'\n";
164 708
165 open my $fh, "<:utf8", $path 709 open my $fh, "<:utf8", $path
166 or die "$path: $!"; 710 or die "$path: $!";
… …
170 . "#line 1 \"$path\"\n{\n" 714 . "#line 1 \"$path\"\n{\n"
171 . (do { local $/; <$fh> }) 715 . (do { local $/; <$fh> })
172 . "\n};\n1"; 716 . "\n};\n1";
173 717
174 eval $source 718 eval $source
175 or die "$path: $@"; 719 or die $@ ? "$path: $@\n"
720 : "extension disabled.\n";
176 721
177 push @exts, $pkg; 722 push @exts, $pkg;
178 $ext_pkg{$base} = $pkg; 723 $ext_pkg{$base} = $pkg;
179 724
180# no strict 'refs'; 725# no strict 'refs';
… …
187 my ($pkg) = @_; 732 my ($pkg) = @_;
188 733
189 warn "removing extension $pkg\n"; 734 warn "removing extension $pkg\n";
190 735
191 # remove hooks 736 # remove hooks
737 #TODO
192 for my $idx (0 .. $#EVENT) { 738# for my $idx (0 .. $#PLUGIN_EVENT) {
193 delete $hook[$idx]{$pkg}; 739# delete $hook[$idx]{$pkg};
194 } 740# }
195 741
196 # remove commands 742 # remove commands
197 for my $name (keys %command) { 743 for my $name (keys %COMMAND) {
198 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 744 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
199 745
200 if (@cb) { 746 if (@cb) {
201 $command{$name} = \@cb; 747 $COMMAND{$name} = \@cb;
202 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
203 } else { 748 } else {
204 delete $command{$name};
205 delete $COMMAND{"$name\000"}; 749 delete $COMMAND{$name};
206 } 750 }
207 } 751 }
208 752
209 # remove extcmds 753 # remove extcmds
210 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 754 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
211 delete $extcmd{$name}; 755 delete $EXTCMD{$name};
212 } 756 }
213 757
214 if (my $cb = $pkg->can ("on_unload")) { 758 if (my $cb = $pkg->can ("unload")) {
215 eval { 759 eval {
216 $cb->($pkg); 760 $cb->($pkg);
217 1 761 1
218 } or warn "$pkg unloaded, but with errors: $@"; 762 } or warn "$pkg unloaded, but with errors: $@";
219 } 763 }
220 764
221 Symbol::delete_package $pkg; 765 Symbol::delete_package $pkg;
222} 766}
223 767
224sub load_extensions { 768sub load_extensions {
225 my $LIBDIR = maps_directory "perl";
226
227 for my $ext (<$LIBDIR/*.ext>) { 769 for my $ext (<$LIBDIR/*.ext>) {
228 next unless -r $ext; 770 next unless -r $ext;
229 eval { 771 eval {
230 load_extension $ext; 772 load_extension $ext;
231 1 773 1
232 } or warn "$ext not loaded: $@"; 774 } or warn "$ext not loaded: $@";
233 } 775 }
234} 776}
235 777
236register_command "perl-reload", 0, sub {
237 my ($who, $arg) = @_;
238
239 if ($who->flag (FLAG_WIZ)) {
240 $who->message ("reloading...");
241
242 warn "reloading...\n";
243 eval {
244 # 1. cancel all watchers
245 $_->cancel for Event::all_watchers;
246
247 # 2. unload all extensions
248 for (@exts) {
249 $who->message ("unloading <$_>");
250 unload_extension $_;
251 }
252
253 # 3. unload all modules loaded from $LIBDIR
254 while (my ($k, $v) = each %INC) {
255 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
256
257 $who->message ("removing <$k>");
258 delete $INC{$k};
259
260 $k =~ s/\.pm$//;
261 $k =~ s/\//::/g;
262
263 if (my $cb = $k->can ("unload_module")) {
264 $cb->();
265 }
266
267 Symbol::delete_package $k;
268 }
269
270 # 4. get rid of ext::, as good as possible
271 Symbol::delete_package "ext::$_"
272 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);
273
274 # 5. remove register_script_function callbacks
275 # TODO
276
277 # 6. unload cf.pm "a bit"
278 delete $INC{"cf.pm"};
279
280 # don't, removes xs symbols, too
281 #Symbol::delete_package __PACKAGE__;
282
283 # 7. reload cf.pm
284 $who->message ("reloading cf.pm");
285 require cf;
286 };
287 warn $@ if $@;
288 $who->message ($@) if $@;
289 warn "reloaded\n";
290
291 $who->message ("reloaded");
292 } else {
293 $who->message ("Intruder Alert!");
294 }
295};
296
297#############################################################################
298# utility functions
299
300use JSON::Syck (); # TODO# replace by JSON::PC once working
301
302sub from_json($) {
303 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
304 JSON::Syck::Load $_[0]
305}
306
307sub to_json($) {
308 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
309 JSON::Syck::Dump $_[0]
310}
311
312#############################################################################
313# extcmd framework, basically convert ext <msg>
314# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
315
316sub on_extcmd {
317 my ($pl, $buf) = @_;
318
319 my $msg = eval { from_json $buf };
320
321 if (ref $msg) {
322 if (my $cb = $extcmd{$msg->{msgtype}}) {
323 if (my %reply = $cb->[0]->($pl, $msg)) {
324 $pl->ext_reply ($msg->{msgid}, %reply);
325 }
326 }
327 } else {
328 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
329 }
330
331 1
332}
333
334############################################################################# 778#############################################################################
335# load/save/clean perl data associated with a map 779# load/save/clean perl data associated with a map
336 780
337*on_mapclean = sub { 781*cf::mapsupport::on_clean = sub {
338 my ($map) = @_; 782 my ($map) = @_;
339 783
340 my $path = $map->tmpname; 784 my $path = $map->tmpname;
341 defined $path or return; 785 defined $path or return;
342 786
343 unlink "$path.cfperl"; 787 unlink "$path.pst";
344}; 788};
345 789
346*on_mapin = 790cf::map->attach (prio => -10000, package => cf::mapsupport::);
347*on_mapload = sub {
348 my ($map) = @_;
349
350 my $path = $map->tmpname;
351 $path = $map->path unless defined $path;
352
353 open my $fh, "<:raw", "$path.cfperl"
354 or return; # no perl data
355
356 my $data = Storable::thaw do { local $/; <$fh> };
357
358 $data->{version} <= 1
359 or return; # too new
360
361 $map->_set_obs ($data->{obs});
362};
363
364*on_mapout = sub {
365 my ($map) = @_;
366
367 my $path = $map->tmpname;
368 $path = $map->path unless defined $path;
369
370 my $obs = $map->_get_obs;
371
372 if (defined $obs) {
373 open my $fh, ">:raw", "$path.cfperl"
374 or die "$path.cfperl: $!";
375
376 stat $path;
377
378 print $fh Storable::nfreeze {
379 size => (stat _)[7],
380 time => (stat _)[9],
381 version => 1,
382 obs => $obs,
383 };
384
385 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
386 } else {
387 unlink "$path.cfperl";
388 }
389};
390 791
391############################################################################# 792#############################################################################
392# load/save perl data associated with player->ob objects 793# load/save perl data associated with player->ob objects
393 794
394sub all_objects(@) { 795sub all_objects(@) {
395 @_, map all_objects ($_->inv), @_ 796 @_, map all_objects ($_->inv), @_
396} 797}
397 798
398*on_player_load = sub { 799# TODO: compatibility cruft, remove when no longer needed
800cf::player->attach (
801 on_load => sub {
399 my ($ob, $path) = @_; 802 my ($pl, $path) = @_;
400 803
401 for my $o (all_objects $ob) { 804 for my $o (all_objects $pl->ob) {
402 if (my $value = $o->get_ob_key_value ("_perl_data")) { 805 if (my $value = $o->get_ob_key_value ("_perl_data")) {
403 $o->set_ob_key_value ("_perl_data"); 806 $o->set_ob_key_value ("_perl_data");
404 807
405 %$o = %{ Storable::thaw pack "H*", $value }; 808 %$o = %{ Storable::thaw pack "H*", $value };
406 } 809 }
810 }
407 } 811 },
408}; 812);
409
410*on_player_save = sub {
411 my ($ob, $path) = @_;
412
413 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
414 for grep %$_, all_objects $ob;
415};
416 813
417############################################################################# 814#############################################################################
418# 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
419 823
420=item cf::player::exists $login 824=item cf::player::exists $login
421 825
422Returns true when the given account exists. 826Returns true when the given account exists.
423 827
… …
426sub cf::player::exists($) { 830sub cf::player::exists($) {
427 cf::player::find $_[0] 831 cf::player::find $_[0]
428 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;
429} 833}
430 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
431=item $player->reply ($npc, $msg[, $flags]) 855=item $player_object->reply ($npc, $msg[, $flags])
432 856
433Sends 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>
434can 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
435dialogue with the given NPC character. 859dialogue with the given NPC character.
436 860
437=cut 861=cut
438 862
439# rough implementation of a future "reply" method that works 863# rough implementation of a future "reply" method that works
440# with dialog boxes. 864# with dialog boxes.
865#TODO: the first argument must go, split into a $npc->reply_to ( method
441sub cf::object::player::reply($$$;$) { 866sub cf::object::player::reply($$$;$) {
442 my ($self, $npc, $msg, $flags) = @_; 867 my ($self, $npc, $msg, $flags) = @_;
443 868
444 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 869 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
445 870
… …
449 $msg = $npc->name . " says: $msg" if $npc; 874 $msg = $npc->name . " says: $msg" if $npc;
450 $self->message ($msg, $flags); 875 $self->message ($msg, $flags);
451 } 876 }
452} 877}
453 878
454=item $player->ext_reply ($msgid, $msgtype, %msg) 879=item $player_object->may ("access")
455 880
456Sends an ext reply to the player. 881Returns wether the given player is authorized to access resource "access"
882(e.g. "command_wizcast").
457 883
458=cut 884=cut
459 885
460sub 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 {
461 my ($self, $id, %msg) = @_; 972 my ($self, $cb) = @_;
462 973
463 $msg{msgid} = $id; 974 my $coro; $coro = async {
975 eval {
976 $cb->();
977 };
978 warn $@ if $@;
979 };
464 980
465 $self->send ("ext " . to_json \%msg); 981 $coro->on_destroy (sub {
466} 982 delete $self->{_coro}{$coro+0};
983 });
467 984
468############################################################################# 985 $self->{_coro}{$coro+0} = $coro;
469# map scripting support
470 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
471our $safe = new Safe "ext"; 1011our $safe = new Safe "safe";
472our $safe_hole = new Safe::Hole; 1012our $safe_hole = new Safe::Hole;
473 1013
474$SIG{FPE} = 'IGNORE'; 1014$SIG{FPE} = 'IGNORE';
475 1015
476$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));
477 1017
478# here we export the classes and methods available to script code 1018# here we export the classes and methods available to script code
479 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
480for ( 1031for (
481 ["cf::object" => qw(contr pay_amount pay_player)], 1032 ["cf::object" => qw(contr pay_amount pay_player map)],
482 ["cf::object::player" => qw(player)], 1033 ["cf::object::player" => qw(player)],
483 ["cf::player" => qw(peaceful)], 1034 ["cf::player" => qw(peaceful)],
1035 ["cf::map" => qw(trigger)],
484) { 1036) {
485 no strict 'refs'; 1037 no strict 'refs';
486 my ($pkg, @funs) = @$_; 1038 my ($pkg, @funs) = @$_;
487 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 1039 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
488 for @funs; 1040 for @funs;
489} 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
490 1054
491sub safe_eval($;@) { 1055sub safe_eval($;@) {
492 my ($code, %vars) = @_; 1056 my ($code, %vars) = @_;
493 1057
494 my $qcode = $code; 1058 my $qcode = $code;
495 $qcode =~ s/"/‟/g; # not allowed in #line filenames 1059 $qcode =~ s/"/‟/g; # not allowed in #line filenames
496 $qcode =~ s/\n/\\n/g; 1060 $qcode =~ s/\n/\\n/g;
497 1061
498 local $_; 1062 local $_;
499 local @ext::cf::_safe_eval_args = values %vars; 1063 local @safe::cf::_safe_eval_args = values %vars;
500 1064
501 $code = 1065 my $eval =
502 "do {\n" 1066 "do {\n"
503 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 1067 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
504 . "#line 0 \"{$qcode}\"\n" 1068 . "#line 0 \"{$qcode}\"\n"
505 . $code 1069 . $code
506 . "\n}" 1070 . "\n}"
507 ; 1071 ;
508 1072
509 sub_generation_inc; 1073 sub_generation_inc;
510 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 1074 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
511 sub_generation_inc; 1075 sub_generation_inc;
512 1076
1077 if ($@) {
1078 warn "$@";
1079 warn "while executing safe code '$code'\n";
1080 warn "with arguments " . (join " ", %vars) . "\n";
1081 }
1082
513 wantarray ? @res : $res[0] 1083 wantarray ? @res : $res[0]
514} 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
515 1100
516sub register_script_function { 1101sub register_script_function {
517 my ($fun, $cb) = @_; 1102 my ($fun, $cb) = @_;
518 1103
519 no strict 'refs'; 1104 no strict 'refs';
520 *{"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 );
521} 1215}
522 1216
523############################################################################# 1217#############################################################################
524# the server's main() 1218# the server's main()
525 1219
526sub 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;
527 Event::loop; 1232 Event::loop;
528} 1233}
529 1234
530############################################################################# 1235#############################################################################
531# initialisation 1236# initialisation
532 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
533register "<global>", __PACKAGE__; 1322register "<global>", __PACKAGE__;
534 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
535unshift @INC, $LIBDIR; 1333unshift @INC, $LIBDIR;
536 1334
537load_extensions;
538
539$TICK_WATCHER = Event->timer ( 1335$TICK_WATCHER = Event->timer (
540 prio => 1, 1336 prio => 0,
541 at => $NEXT_TICK || 1, 1337 at => $NEXT_TICK || $TICK,
1338 data => WF_AUTOCANCEL,
542 cb => sub { 1339 cb => sub {
1340 unless ($FREEZE) {
543 cf::server_tick; # one server iteration 1341 cf::server_tick; # one server iteration
1342 $RUNTIME += $TICK;
1343 }
544 1344
545 my $NOW = Event::time;
546 $NEXT_TICK += $TICK; 1345 $NEXT_TICK += $TICK;
547 1346
548 # if we are delayed by > 0.25 second, skip ticks 1347 # if we are delayed by four ticks or more, skip them all
549 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + .25; 1348 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
550 1349
551 $TICK_WATCHER->at ($NEXT_TICK); 1350 $TICK_WATCHER->at ($NEXT_TICK);
552 $TICK_WATCHER->start; 1351 $TICK_WATCHER->start;
553 }, 1352 },
554); 1353);
555 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
5561 13721
557 1373

Diff Legend

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