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

Diff Legend

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