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.36 by root, Thu Aug 24 14:04:29 2006 UTC vs.
Revision 1.104 by root, Sat Dec 30 16:56:16 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
236sub _perl_reload(&) {
237 my ($msg) = @_;
238
239 $msg->("reloading...");
240
241 eval {
242 # 1. cancel all watchers
243 $_->cancel for Event::all_watchers;
244
245 # 2. unload all extensions
246 for (@exts) {
247 $msg->("unloading <$_>");
248 unload_extension $_;
249 }
250
251 # 3. unload all modules loaded from $LIBDIR
252 while (my ($k, $v) = each %INC) {
253 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
254
255 $msg->("removing <$k>");
256 delete $INC{$k};
257
258 $k =~ s/\.pm$//;
259 $k =~ s/\//::/g;
260
261 if (my $cb = $k->can ("unload_module")) {
262 $cb->();
263 }
264
265 Symbol::delete_package $k;
266 }
267
268 # 4. get rid of ext::, as good as possible
269 Symbol::delete_package "ext::$_"
270 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);
271
272 # 5. remove register_script_function callbacks
273 # TODO
274
275 # 6. unload cf.pm "a bit"
276 delete $INC{"cf.pm"};
277
278 # don't, removes xs symbols, too
279 #Symbol::delete_package __PACKAGE__;
280
281 # 7. reload cf.pm
282 $msg->("reloading cf.pm");
283 require cf;
284 };
285 $msg->($@) if $@;
286
287 $msg->("reloaded");
288};
289
290sub perl_reload() {
291 _perl_reload {
292 warn $_[0];
293 print "$_[0]\n";
294 };
295}
296
297register_command "perl-reload", 0, sub {
298 my ($who, $arg) = @_;
299
300 if ($who->flag (FLAG_WIZ)) {
301 _perl_reload {
302 warn $_[0];
303 $who->message ($_[0]);
304 };
305 }
306};
307
308#############################################################################
309# utility functions
310
311use JSON::Syck (); # TODO# replace by JSON::PC once working
312
313sub from_json($) {
314 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
315 JSON::Syck::Load $_[0]
316}
317
318sub to_json($) {
319 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
320 JSON::Syck::Dump $_[0]
321}
322
323#############################################################################
324# extcmd framework, basically convert ext <msg>
325# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
326
327sub on_extcmd {
328 my ($pl, $buf) = @_;
329
330 my $msg = eval { from_json $buf };
331
332 if (ref $msg) {
333 if (my $cb = $extcmd{$msg->{msgtype}}) {
334 if (my %reply = $cb->[0]->($pl, $msg)) {
335 $pl->ext_reply ($msg->{msgid}, %reply);
336 }
337 }
338 } else {
339 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
340 }
341
342 1
343}
344
345############################################################################# 778#############################################################################
346# load/save/clean perl data associated with a map 779# load/save/clean perl data associated with a map
347 780
348*on_mapclean = sub { 781*cf::mapsupport::on_clean = sub {
349 my ($map) = @_; 782 my ($map) = @_;
350 783
351 my $path = $map->tmpname; 784 my $path = $map->tmpname;
352 defined $path or return; 785 defined $path or return;
353 786
354 unlink "$path.cfperl"; 787 unlink "$path.pst";
355}; 788};
356 789
357*on_mapin = 790cf::map->attach (prio => -10000, package => cf::mapsupport::);
358*on_mapload = sub {
359 my ($map) = @_;
360
361 my $path = $map->tmpname;
362 $path = $map->path unless defined $path;
363
364 open my $fh, "<:raw", "$path.cfperl"
365 or return; # no perl data
366
367 my $data = Storable::thaw do { local $/; <$fh> };
368
369 $data->{version} <= 1
370 or return; # too new
371
372 $map->_set_obs ($data->{obs});
373};
374
375*on_mapout = sub {
376 my ($map) = @_;
377
378 my $path = $map->tmpname;
379 $path = $map->path unless defined $path;
380
381 my $obs = $map->_get_obs;
382
383 if (defined $obs) {
384 open my $fh, ">:raw", "$path.cfperl"
385 or die "$path.cfperl: $!";
386
387 stat $path;
388
389 print $fh Storable::nfreeze {
390 size => (stat _)[7],
391 time => (stat _)[9],
392 version => 1,
393 obs => $obs,
394 };
395
396 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
397 } else {
398 unlink "$path.cfperl";
399 }
400};
401 791
402############################################################################# 792#############################################################################
403# load/save perl data associated with player->ob objects 793# load/save perl data associated with player->ob objects
404 794
405sub all_objects(@) { 795sub all_objects(@) {
406 @_, map all_objects ($_->inv), @_ 796 @_, map all_objects ($_->inv), @_
407} 797}
408 798
409*on_player_load = sub { 799# TODO: compatibility cruft, remove when no longer needed
800cf::player->attach (
801 on_load => sub {
410 my ($ob, $path) = @_; 802 my ($pl, $path) = @_;
411 803
412 for my $o (all_objects $ob) { 804 for my $o (all_objects $pl->ob) {
413 if (my $value = $o->get_ob_key_value ("_perl_data")) { 805 if (my $value = $o->get_ob_key_value ("_perl_data")) {
414 $o->set_ob_key_value ("_perl_data"); 806 $o->set_ob_key_value ("_perl_data");
415 807
416 %$o = %{ Storable::thaw pack "H*", $value }; 808 %$o = %{ Storable::thaw pack "H*", $value };
417 } 809 }
810 }
418 } 811 },
419}; 812);
420
421*on_player_save = sub {
422 my ($ob, $path) = @_;
423
424 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
425 for grep %$_, all_objects $ob;
426};
427 813
428############################################################################# 814#############################################################################
429# 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
430 823
431=item cf::player::exists $login 824=item cf::player::exists $login
432 825
433Returns true when the given account exists. 826Returns true when the given account exists.
434 827
… …
437sub cf::player::exists($) { 830sub cf::player::exists($) {
438 cf::player::find $_[0] 831 cf::player::find $_[0]
439 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;
440} 833}
441 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
442=item $player->reply ($npc, $msg[, $flags]) 855=item $player_object->reply ($npc, $msg[, $flags])
443 856
444Sends 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>
445can 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
446dialogue with the given NPC character. 859dialogue with the given NPC character.
447 860
448=cut 861=cut
449 862
450# rough implementation of a future "reply" method that works 863# rough implementation of a future "reply" method that works
451# with dialog boxes. 864# with dialog boxes.
865#TODO: the first argument must go, split into a $npc->reply_to ( method
452sub cf::object::player::reply($$$;$) { 866sub cf::object::player::reply($$$;$) {
453 my ($self, $npc, $msg, $flags) = @_; 867 my ($self, $npc, $msg, $flags) = @_;
454 868
455 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 869 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
456 870
… …
460 $msg = $npc->name . " says: $msg" if $npc; 874 $msg = $npc->name . " says: $msg" if $npc;
461 $self->message ($msg, $flags); 875 $self->message ($msg, $flags);
462 } 876 }
463} 877}
464 878
465=item $player->ext_reply ($msgid, $msgtype, %msg) 879=item $player_object->may ("access")
466 880
467Sends an ext reply to the player. 881Returns wether the given player is authorized to access resource "access"
882(e.g. "command_wizcast").
468 883
469=cut 884=cut
470 885
471sub 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 {
472 my ($self, $id, %msg) = @_; 972 my ($self, $cb) = @_;
473 973
474 $msg{msgid} = $id; 974 my $coro; $coro = async {
975 eval {
976 $cb->();
977 };
978 warn $@ if $@;
979 };
475 980
476 $self->send ("ext " . to_json \%msg); 981 $coro->on_destroy (sub {
477} 982 delete $self->{_coro}{$coro+0};
983 });
478 984
479############################################################################# 985 $self->{_coro}{$coro+0} = $coro;
480# map scripting support
481 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
482our $safe = new Safe "ext"; 1011our $safe = new Safe "safe";
483our $safe_hole = new Safe::Hole; 1012our $safe_hole = new Safe::Hole;
484 1013
485$SIG{FPE} = 'IGNORE'; 1014$SIG{FPE} = 'IGNORE';
486 1015
487$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));
488 1017
489# here we export the classes and methods available to script code 1018# here we export the classes and methods available to script code
490 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
491for ( 1031for (
492 ["cf::object" => qw(contr pay_amount pay_player)], 1032 ["cf::object" => qw(contr pay_amount pay_player map)],
493 ["cf::object::player" => qw(player)], 1033 ["cf::object::player" => qw(player)],
494 ["cf::player" => qw(peaceful)], 1034 ["cf::player" => qw(peaceful)],
1035 ["cf::map" => qw(trigger)],
495) { 1036) {
496 no strict 'refs'; 1037 no strict 'refs';
497 my ($pkg, @funs) = @$_; 1038 my ($pkg, @funs) = @$_;
498 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 1039 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
499 for @funs; 1040 for @funs;
500} 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
501 1054
502sub safe_eval($;@) { 1055sub safe_eval($;@) {
503 my ($code, %vars) = @_; 1056 my ($code, %vars) = @_;
504 1057
505 my $qcode = $code; 1058 my $qcode = $code;
506 $qcode =~ s/"/‟/g; # not allowed in #line filenames 1059 $qcode =~ s/"/‟/g; # not allowed in #line filenames
507 $qcode =~ s/\n/\\n/g; 1060 $qcode =~ s/\n/\\n/g;
508 1061
509 local $_; 1062 local $_;
510 local @ext::cf::_safe_eval_args = values %vars; 1063 local @safe::cf::_safe_eval_args = values %vars;
511 1064
512 $code = 1065 my $eval =
513 "do {\n" 1066 "do {\n"
514 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 1067 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
515 . "#line 0 \"{$qcode}\"\n" 1068 . "#line 0 \"{$qcode}\"\n"
516 . $code 1069 . $code
517 . "\n}" 1070 . "\n}"
518 ; 1071 ;
519 1072
520 sub_generation_inc; 1073 sub_generation_inc;
521 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 1074 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
522 sub_generation_inc; 1075 sub_generation_inc;
523 1076
1077 if ($@) {
1078 warn "$@";
1079 warn "while executing safe code '$code'\n";
1080 warn "with arguments " . (join " ", %vars) . "\n";
1081 }
1082
524 wantarray ? @res : $res[0] 1083 wantarray ? @res : $res[0]
525} 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
526 1100
527sub register_script_function { 1101sub register_script_function {
528 my ($fun, $cb) = @_; 1102 my ($fun, $cb) = @_;
529 1103
530 no strict 'refs'; 1104 no strict 'refs';
531 *{"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 );
532} 1215}
533 1216
534############################################################################# 1217#############################################################################
535# the server's main() 1218# the server's main()
536 1219
537sub 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;
538 Event::loop; 1232 Event::loop;
539} 1233}
540 1234
541############################################################################# 1235#############################################################################
542# initialisation 1236# initialisation
543 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
544register "<global>", __PACKAGE__; 1322register "<global>", __PACKAGE__;
545 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
546unshift @INC, $LIBDIR; 1333unshift @INC, $LIBDIR;
547 1334
548load_extensions;
549
550$TICK_WATCHER = Event->timer ( 1335$TICK_WATCHER = Event->timer (
1336 reentrant => 0,
551 prio => 1, 1337 prio => 0,
552 at => $NEXT_TICK || 1, 1338 at => $NEXT_TICK || $TICK,
1339 data => WF_AUTOCANCEL,
553 cb => sub { 1340 cb => sub {
1341 unless ($FREEZE) {
554 cf::server_tick; # one server iteration 1342 cf::server_tick; # one server iteration
1343 $RUNTIME += $TICK;
1344 }
555 1345
556 my $NOW = Event::time;
557 $NEXT_TICK += $TICK; 1346 $NEXT_TICK += $TICK;
558 1347
559 # if we are delayed by > 0.25 second, skip ticks 1348 # if we are delayed by four ticks or more, skip them all
560 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + .25; 1349 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
561 1350
562 $TICK_WATCHER->at ($NEXT_TICK); 1351 $TICK_WATCHER->at ($NEXT_TICK);
563 $TICK_WATCHER->start; 1352 $TICK_WATCHER->start;
564 }, 1353 },
565); 1354);
566 1355
1356IO::AIO::max_poll_time $TICK * 0.2;
1357
1358Event->io (fd => IO::AIO::poll_fileno,
1359 poll => 'r',
1360 prio => 5,
1361 data => WF_AUTOCANCEL,
1362 cb => \&IO::AIO::poll_cb);
1363
1364# we must not ever block the main coroutine
1365$Coro::idle = sub {
1366 #Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#
1367 warn "FATAL: Coro::idle was called, major BUG\n";
1368 (Coro::unblock_sub {
1369 Event::one_event;
1370 })->();
1371};
1372
5671 13731
568 1374

Diff Legend

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