ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
(Generate patch)

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.38 by root, Thu Aug 24 17:29:30 2006 UTC vs.
Revision 1.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;
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 ();
10use Time::HiRes; 24use Time::HiRes;
11use Event; 25
12$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
13 27
14use strict; 28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
29$YAML::Syck::ImplicitUnicode = 1;
15 30
16our %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
17our @EVENT; 39our @EVENT;
18our @PLUGIN_EVENT; 40our $LIBDIR = datadir . "/ext";
19our %PROP_TYPE;
20our %PROP_IDX;
21our $LIBDIR = maps_directory "perl";
22 41
23our $TICK = MAX_TIME * 1e-6; 42our $TICK = MAX_TIME * 1e-6;
24our $TICK_WATCHER; 43our $TICK_WATCHER;
25our $NEXT_TICK; 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
26 113
27BEGIN { 114BEGIN {
28 @PLUGIN_EVENT = map lc, @PLUGIN_EVENT;
29
30 *CORE::GLOBAL::warn = sub { 115 *CORE::GLOBAL::warn = sub {
31 my $msg = join "", @_; 116 my $msg = join "", @_;
117 utf8::encode $msg;
118
32 $msg .= "\n" 119 $msg .= "\n"
33 unless $msg =~ /\n$/; 120 unless $msg =~ /\n$/;
34 121
35 print STDERR "cfperl: $msg";
36 LOG llevError, "cfperl: $msg"; 122 LOG llevError, "cfperl: $msg";
37 }; 123 };
38} 124}
39 125
40my %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';
41 132
42# generate property mutators 133# we bless all objects into (empty) derived classes to force a method lookup
43sub prop_gen { 134# within the Safe compartment.
44 my ($prefix, $class) = @_; 135for my $pkg (qw(
45 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)) {
46 no strict 'refs'; 142 no strict 'refs';
47
48 for my $prop (keys %PROP_TYPE) {
49 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
50 my $sub = lc $1;
51
52 my $type = $PROP_TYPE{$prop};
53 my $idx = $PROP_IDX {$prop};
54
55 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
56 $_[0]->get_property ($type, $idx)
57 };
58
59 *{"$class\::set_$sub"} = sub {
60 $_[0]->set_property ($type, $idx, $_[1]);
61 } unless $ignore_set{$prop};
62 }
63}
64
65# auto-generate most of the API
66
67prop_gen OBJECT_PROP => "cf::object";
68# CFAPI_OBJECT_ANIMATION?
69prop_gen PLAYER_PROP => "cf::object::player";
70
71prop_gen MAP_PROP => "cf::map";
72prop_gen ARCH_PROP => "cf::arch";
73
74# guessed hierarchies
75
76@ext::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
77@ext::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
78
79# we bless all objects into derived classes to force a method lookup
80# within the Safe compartment.
81for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {
82 no strict 'refs';
83 @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 143 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
84} 144}
85 145
86$Event::DIED = sub { 146$Event::DIED = sub {
87 warn "error in event callback: @_"; 147 warn "error in event callback: @_";
88}; 148};
89 149
90my %ext_pkg; 150my %ext_pkg;
91my @exts; 151my @exts;
92my @hook; 152my @hook;
93my %command;
94my %extcmd;
95 153
96sub inject_event { 154=head2 UTILITY FUNCTIONS
97 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(&) {
98 my $event_code = shift; 233 my $cb = shift;
99 234
100 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
101 or return; 254 or return;
102 255
103 &$cb 256 my $value = $cf::RUNTIME;
104} 257 (aio_write $fh, 0, (length $value), $value, 0) <= 0
258 and return;
105 259
106sub 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 {
107 my $event = shift; 656 my $event = shift;
657 my $callbacks = shift;
108 658
109 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
110 or return; 795 or return;
111 796
112 List::Util::max map &$_, values %$cb 797 unless (aio_stat "$filename.pst") {
113} 798 (aio_load "$filename.pst", $av) >= 0
114 799 or return;
115sub inject_command { 800 $av = eval { (Storable::thaw <$av>)->{objs} };
116 my ($name, $obj, $params) = @_;
117
118 for my $cmd (@{ $command{$name} }) {
119 $cmd->[1]->($obj, $params);
120 } 801 }
121 802
122 -1 803 return ($data, $av);
123} 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
124 815
125sub register_command { 816sub register_command {
126 my ($name, $time, $cb) = @_; 817 my ($name, $cb) = @_;
127 818
128 my $caller = caller; 819 my $caller = caller;
129 #warn "registering command '$name/$time' to '$caller'"; 820 #warn "registering command '$name/$time' to '$caller'";
130 821
131 push @{ $command{$name} }, [$time, $cb, $caller]; 822 push @{ $COMMAND{$name} }, [$caller, $cb];
132 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
133} 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
134 833
135sub register_extcmd { 834sub register_extcmd {
136 my ($name, $cb) = @_; 835 my ($name, $cb) = @_;
137 836
138 my $caller = caller; 837 my $caller = caller;
139 #warn "registering extcmd '$name' to '$caller'"; 838 #warn "registering extcmd '$name' to '$caller'";
140 839
141 $extcmd{$name} = [$cb, $caller]; 840 $EXTCMD{$name} = [$cb, $caller];
142} 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);
143 874
144sub register { 875sub register {
145 my ($base, $pkg) = @_; 876 my ($base, $pkg) = @_;
146 877
147 for my $idx (0 .. $#PLUGIN_EVENT) { 878 #TODO
148 if (my $ref = $pkg->can ("on_$PLUGIN_EVENT[$idx]")) {
149 #warn "registering $PLUGIN_EVENT[$idx] hook to '$pkg'\n";
150 $hook[$idx]{$base} = $ref;
151 }
152 }
153} 879}
154 880
155sub load_extension { 881sub load_extension {
156 my ($path) = @_; 882 my ($path) = @_;
157 883
158 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 884 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
159 my $base = $1; 885 my $base = $1;
160 my $pkg = $1; 886 my $pkg = $1;
161 $pkg =~ s/[^[:word:]]/_/g; 887 $pkg =~ s/[^[:word:]]/_/g;
162 $pkg = "cf::ext::$pkg"; 888 $pkg = "ext::$pkg";
163 889
164 warn "loading '$path' into '$pkg'\n"; 890 warn "loading '$path' into '$pkg'\n";
165 891
166 open my $fh, "<:utf8", $path 892 open my $fh, "<:utf8", $path
167 or die "$path: $!"; 893 or die "$path: $!";
… …
171 . "#line 1 \"$path\"\n{\n" 897 . "#line 1 \"$path\"\n{\n"
172 . (do { local $/; <$fh> }) 898 . (do { local $/; <$fh> })
173 . "\n};\n1"; 899 . "\n};\n1";
174 900
175 eval $source 901 eval $source
176 or die "$path: $@"; 902 or die $@ ? "$path: $@\n"
903 : "extension disabled.\n";
177 904
178 push @exts, $pkg; 905 push @exts, $pkg;
179 $ext_pkg{$base} = $pkg; 906 $ext_pkg{$base} = $pkg;
180 907
181# no strict 'refs'; 908# no strict 'refs';
… …
188 my ($pkg) = @_; 915 my ($pkg) = @_;
189 916
190 warn "removing extension $pkg\n"; 917 warn "removing extension $pkg\n";
191 918
192 # remove hooks 919 # remove hooks
920 #TODO
193 for my $idx (0 .. $#PLUGIN_EVENT) { 921# for my $idx (0 .. $#PLUGIN_EVENT) {
194 delete $hook[$idx]{$pkg}; 922# delete $hook[$idx]{$pkg};
195 } 923# }
196 924
197 # remove commands 925 # remove commands
198 for my $name (keys %command) { 926 for my $name (keys %COMMAND) {
199 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 927 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
200 928
201 if (@cb) { 929 if (@cb) {
202 $command{$name} = \@cb; 930 $COMMAND{$name} = \@cb;
203 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
204 } else { 931 } else {
205 delete $command{$name};
206 delete $COMMAND{"$name\000"}; 932 delete $COMMAND{$name};
207 } 933 }
208 } 934 }
209 935
210 # remove extcmds 936 # remove extcmds
211 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 937 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
212 delete $extcmd{$name}; 938 delete $EXTCMD{$name};
213 } 939 }
214 940
215 if (my $cb = $pkg->can ("on_unload")) { 941 if (my $cb = $pkg->can ("unload")) {
216 eval { 942 eval {
217 $cb->($pkg); 943 $cb->($pkg);
218 1 944 1
219 } or warn "$pkg unloaded, but with errors: $@"; 945 } or warn "$pkg unloaded, but with errors: $@";
220 } 946 }
221 947
222 Symbol::delete_package $pkg; 948 Symbol::delete_package $pkg;
223} 949}
224 950
225sub load_extensions { 951sub load_extensions {
226 my $LIBDIR = maps_directory "perl";
227
228 for my $ext (<$LIBDIR/*.ext>) { 952 for my $ext (<$LIBDIR/*.ext>) {
229 next unless -r $ext; 953 next unless -r $ext;
230 eval { 954 eval {
231 load_extension $ext; 955 load_extension $ext;
232 1 956 1
233 } or warn "$ext not loaded: $@"; 957 } or warn "$ext not loaded: $@";
234 } 958 }
235} 959}
236 960
237sub _perl_reload(&) {
238 my ($msg) = @_;
239
240 $msg->("reloading...");
241
242 eval {
243 # 1. cancel all watchers
244 $_->cancel for Event::all_watchers;
245
246 # 2. unload all extensions
247 for (@exts) {
248 $msg->("unloading <$_>");
249 unload_extension $_;
250 }
251
252 # 3. unload all modules loaded from $LIBDIR
253 while (my ($k, $v) = each %INC) {
254 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
255
256 $msg->("removing <$k>");
257 delete $INC{$k};
258
259 $k =~ s/\.pm$//;
260 $k =~ s/\//::/g;
261
262 if (my $cb = $k->can ("unload_module")) {
263 $cb->();
264 }
265
266 Symbol::delete_package $k;
267 }
268
269 # 4. get rid of ext::, as good as possible
270 Symbol::delete_package "ext::$_"
271 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);
272
273 # 5. remove register_script_function callbacks
274 # TODO
275
276 # 6. unload cf.pm "a bit"
277 delete $INC{"cf.pm"};
278
279 # don't, removes xs symbols, too
280 #Symbol::delete_package __PACKAGE__;
281
282 # 7. reload cf.pm
283 $msg->("reloading cf.pm");
284 require cf;
285 };
286 $msg->($@) if $@;
287
288 $msg->("reloaded");
289};
290
291sub perl_reload() {
292 _perl_reload {
293 warn $_[0];
294 print "$_[0]\n";
295 };
296}
297
298register_command "perl-reload", 0, sub {
299 my ($who, $arg) = @_;
300
301 if ($who->flag (FLAG_WIZ)) {
302 _perl_reload {
303 warn $_[0];
304 $who->message ($_[0]);
305 };
306 }
307};
308
309#############################################################################
310# utility functions
311
312use JSON::Syck (); # TODO# replace by JSON::PC once working
313
314sub from_json($) {
315 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
316 JSON::Syck::Load $_[0]
317}
318
319sub to_json($) {
320 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
321 JSON::Syck::Dump $_[0]
322}
323
324#############################################################################
325# extcmd framework, basically convert ext <msg>
326# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
327
328sub on_extcmd {
329 my ($pl, $buf) = @_;
330
331 my $msg = eval { from_json $buf };
332
333 if (ref $msg) {
334 if (my $cb = $extcmd{$msg->{msgtype}}) {
335 if (my %reply = $cb->[0]->($pl, $msg)) {
336 $pl->ext_reply ($msg->{msgid}, %reply);
337 }
338 }
339 } else {
340 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
341 }
342
343 1
344}
345
346############################################################################# 961#############################################################################
347# load/save/clean perl data associated with a map 962# load/save/clean perl data associated with a map
348 963
349*on_mapclean = sub { 964*cf::mapsupport::on_clean = sub {
350 my ($map) = @_; 965 my ($map) = @_;
351 966
352 my $path = $map->tmpname; 967 my $path = $map->tmpname;
353 defined $path or return; 968 defined $path or return;
354 969
355 unlink "$path.cfperl"; 970 unlink "$path.pst";
356}; 971};
357 972
358*on_mapin = 973cf::map->attach (prio => -10000, package => cf::mapsupport::);
359*on_mapload = sub {
360 my ($map) = @_;
361
362 my $path = $map->tmpname;
363 $path = $map->path unless defined $path;
364
365 open my $fh, "<:raw", "$path.cfperl"
366 or return; # no perl data
367
368 my $data = Storable::thaw do { local $/; <$fh> };
369
370 $data->{version} <= 1
371 or return; # too new
372
373 $map->_set_obs ($data->{obs});
374};
375
376*on_mapout = sub {
377 my ($map) = @_;
378
379 my $path = $map->tmpname;
380 $path = $map->path unless defined $path;
381
382 my $obs = $map->_get_obs;
383
384 if (defined $obs) {
385 open my $fh, ">:raw", "$path.cfperl"
386 or die "$path.cfperl: $!";
387
388 stat $path;
389
390 print $fh Storable::nfreeze {
391 size => (stat _)[7],
392 time => (stat _)[9],
393 version => 1,
394 obs => $obs,
395 };
396
397 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
398 } else {
399 unlink "$path.cfperl";
400 }
401};
402 974
403############################################################################# 975#############################################################################
404# load/save perl data associated with player->ob objects 976# load/save perl data associated with player->ob objects
405 977
406sub all_objects(@) { 978sub all_objects(@) {
407 @_, map all_objects ($_->inv), @_ 979 @_, map all_objects ($_->inv), @_
408} 980}
409 981
410*on_player_load = sub { 982# TODO: compatibility cruft, remove when no longer needed
983cf::player->attach (
984 on_load => sub {
411 my ($ob, $path) = @_; 985 my ($pl, $path) = @_;
412 986
413 for my $o (all_objects $ob) { 987 for my $o (all_objects $pl->ob) {
414 if (my $value = $o->get_ob_key_value ("_perl_data")) { 988 if (my $value = $o->get_ob_key_value ("_perl_data")) {
415 $o->set_ob_key_value ("_perl_data"); 989 $o->set_ob_key_value ("_perl_data");
416 990
417 %$o = %{ Storable::thaw pack "H*", $value }; 991 %$o = %{ Storable::thaw pack "H*", $value };
418 } 992 }
993 }
419 } 994 },
420}; 995);
421
422*on_player_save = sub {
423 my ($ob, $path) = @_;
424
425 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
426 for grep %$_, all_objects $ob;
427};
428 996
429############################################################################# 997#############################################################################
430# 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
431 1006
432=item cf::player::exists $login 1007=item cf::player::exists $login
433 1008
434Returns true when the given account exists. 1009Returns true when the given account exists.
435 1010
… …
438sub cf::player::exists($) { 1013sub cf::player::exists($) {
439 cf::player::find $_[0] 1014 cf::player::find $_[0]
440 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;
441} 1016}
442 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
443=item $player->reply ($npc, $msg[, $flags]) 1038=item $player_object->reply ($npc, $msg[, $flags])
444 1039
445Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 1040Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
446can be C<undef>. Does the right thing when the player is currently in a 1041can be C<undef>. Does the right thing when the player is currently in a
447dialogue with the given NPC character. 1042dialogue with the given NPC character.
448 1043
449=cut 1044=cut
450 1045
451# rough implementation of a future "reply" method that works 1046# rough implementation of a future "reply" method that works
452# with dialog boxes. 1047# with dialog boxes.
1048#TODO: the first argument must go, split into a $npc->reply_to ( method
453sub cf::object::player::reply($$$;$) { 1049sub cf::object::player::reply($$$;$) {
454 my ($self, $npc, $msg, $flags) = @_; 1050 my ($self, $npc, $msg, $flags) = @_;
455 1051
456 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 1052 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
457 1053
… …
461 $msg = $npc->name . " says: $msg" if $npc; 1057 $msg = $npc->name . " says: $msg" if $npc;
462 $self->message ($msg, $flags); 1058 $self->message ($msg, $flags);
463 } 1059 }
464} 1060}
465 1061
466=item $player->ext_reply ($msgid, $msgtype, %msg) 1062=item $player_object->may ("access")
467 1063
468Sends an ext reply to the player. 1064Returns wether the given player is authorized to access resource "access"
1065(e.g. "command_wizcast").
469 1066
470=cut 1067=cut
471 1068
472sub cf::player::ext_reply($$$%) { 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 {
473 my ($self, $id, %msg) = @_; 1155 my ($self, $cb) = @_;
474 1156
475 $msg{msgid} = $id; 1157 my $coro; $coro = async {
1158 eval {
1159 $cb->();
1160 };
1161 warn $@ if $@;
1162 };
476 1163
477 $self->send ("ext " . to_json \%msg); 1164 $coro->on_destroy (sub {
478} 1165 delete $self->{_coro}{$coro+0};
1166 });
479 1167
480############################################################################# 1168 $self->{_coro}{$coro+0} = $coro;
481# map scripting support
482 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
483our $safe = new Safe "ext"; 1194our $safe = new Safe "safe";
484our $safe_hole = new Safe::Hole; 1195our $safe_hole = new Safe::Hole;
485 1196
486$SIG{FPE} = 'IGNORE'; 1197$SIG{FPE} = 'IGNORE';
487 1198
488$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));
489 1200
490# here we export the classes and methods available to script code 1201# here we export the classes and methods available to script code
491 1202
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
492for ( 1214for (
493 ["cf::object" => qw(contr pay_amount pay_player)], 1215 ["cf::object" => qw(contr pay_amount pay_player map)],
494 ["cf::object::player" => qw(player)], 1216 ["cf::object::player" => qw(player)],
495 ["cf::player" => qw(peaceful)], 1217 ["cf::player" => qw(peaceful)],
1218 ["cf::map" => qw(trigger)],
496) { 1219) {
497 no strict 'refs'; 1220 no strict 'refs';
498 my ($pkg, @funs) = @$_; 1221 my ($pkg, @funs) = @$_;
499 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 1222 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
500 for @funs; 1223 for @funs;
501} 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
502 1237
503sub safe_eval($;@) { 1238sub safe_eval($;@) {
504 my ($code, %vars) = @_; 1239 my ($code, %vars) = @_;
505 1240
506 my $qcode = $code; 1241 my $qcode = $code;
507 $qcode =~ s/"/‟/g; # not allowed in #line filenames 1242 $qcode =~ s/"/‟/g; # not allowed in #line filenames
508 $qcode =~ s/\n/\\n/g; 1243 $qcode =~ s/\n/\\n/g;
509 1244
510 local $_; 1245 local $_;
511 local @ext::cf::_safe_eval_args = values %vars; 1246 local @safe::cf::_safe_eval_args = values %vars;
512 1247
513 $code = 1248 my $eval =
514 "do {\n" 1249 "do {\n"
515 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 1250 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
516 . "#line 0 \"{$qcode}\"\n" 1251 . "#line 0 \"{$qcode}\"\n"
517 . $code 1252 . $code
518 . "\n}" 1253 . "\n}"
519 ; 1254 ;
520 1255
521 sub_generation_inc; 1256 sub_generation_inc;
522 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 1257 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
523 sub_generation_inc; 1258 sub_generation_inc;
524 1259
1260 if ($@) {
1261 warn "$@";
1262 warn "while executing safe code '$code'\n";
1263 warn "with arguments " . (join " ", %vars) . "\n";
1264 }
1265
525 wantarray ? @res : $res[0] 1266 wantarray ? @res : $res[0]
526} 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
527 1283
528sub register_script_function { 1284sub register_script_function {
529 my ($fun, $cb) = @_; 1285 my ($fun, $cb) = @_;
530 1286
531 no strict 'refs'; 1287 no strict 'refs';
532 *{"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 );
533} 1398}
534 1399
535############################################################################# 1400#############################################################################
536# the server's main() 1401# the server's main()
537 1402
538sub run { 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;
539 Event::loop; 1423 Event::loop;
540} 1424}
541 1425
542############################################################################# 1426#############################################################################
543# initialisation 1427# initialisation
544 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
545register "<global>", __PACKAGE__; 1534register "<global>", __PACKAGE__;
546 1535
1536register_command "perl-reload" => sub {
1537 my ($who, $arg) = @_;
1538
1539 if ($who->flag (FLAG_WIZ)) {
1540 $who->message ("start of reload.");
1541 perl_reload;
1542 $who->message ("end of reload.");
1543 }
1544};
1545
547unshift @INC, $LIBDIR; 1546unshift @INC, $LIBDIR;
548 1547
549load_extensions;
550
551$TICK_WATCHER = Event->timer ( 1548$TICK_WATCHER = Event->timer (
1549 reentrant => 0,
552 prio => 1, 1550 prio => 0,
553 at => $NEXT_TICK || 1, 1551 at => $NEXT_TICK || $TICK,
1552 data => WF_AUTOCANCEL,
554 cb => sub { 1553 cb => sub {
1554 unless ($FREEZE) {
555 cf::server_tick; # one server iteration 1555 cf::server_tick; # one server iteration
1556 $RUNTIME += $TICK;
1557 }
556 1558
557 my $NOW = Event::time;
558 $NEXT_TICK += $TICK; 1559 $NEXT_TICK += $TICK;
559 1560
560 # if we are delayed by four ticks, skip them all 1561 # if we are delayed by four ticks or more, skip them all
561 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1562 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
562 1563
563 $TICK_WATCHER->at ($NEXT_TICK); 1564 $TICK_WATCHER->at ($NEXT_TICK);
564 $TICK_WATCHER->start; 1565 $TICK_WATCHER->start;
565 }, 1566 },
566); 1567);
567 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);
1590
5681 15911
569 1592

Diff Legend

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