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.5 by root, Wed Feb 8 03:46:15 2006 UTC vs.
Revision 1.67 by root, Tue Sep 12 23:22:32 2006 UTC

1package cf; 1package cf;
2 2
3use Symbol; 3use Symbol;
4use List::Util; 4use List::Util;
5use Storable;
6use Opcode;
7use Safe;
8use Safe::Hole;
9
10use Time::HiRes;
11use Event;
12$Event::Eval = 1; # no idea why this is required, but it is
5 13
6use strict; 14use strict;
7 15
16_init_vars;
17
8our %COMMAND; 18our %COMMAND = ();
9our @EVENT; 19our @EVENT;
10our %PROP_TYPE; 20our $LIBDIR = maps_directory "perl";
11our %PROP_IDX; 21
22our $TICK = MAX_TIME * 1e-6;
23our $TICK_WATCHER;
24our $NEXT_TICK;
12 25
13BEGIN { 26BEGIN {
14 @EVENT = map lc, @EVENT;
15
16 *CORE::GLOBAL::warn = sub { 27 *CORE::GLOBAL::warn = sub {
17 my $msg = join "", @_; 28 my $msg = join "", @_;
18 $msg .= "\n" 29 $msg .= "\n"
19 unless $msg =~ /\n$/; 30 unless $msg =~ /\n$/;
20 31
21 print STDERR "cfperl: $msg"; 32 print STDERR "cfperl: $msg";
22 LOG llevError, "cfperl: $msg"; 33 LOG llevError, "cfperl: $msg";
23 }; 34 };
24} 35}
25 36
26# generate property mutators 37@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
27sub prop_gen {
28 my ($prefix, $class) = @_;
29 38
39# we bless all objects into (empty) derived classes to force a method lookup
40# within the Safe compartment.
41for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) {
30 no strict 'refs'; 42 no strict 'refs';
31 43 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
32 for my $prop (keys %PROP_TYPE) {
33 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
34 my $sub = lc $1;
35
36 my $type = $PROP_TYPE{$prop};
37 my $idx = $PROP_IDX {$prop};
38
39 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
40 $_[0]->get_property ($type, $idx)
41 };
42
43 *{"$class\::set_$sub"} = sub {
44 $_[0]->set_property ($type, $idx, $_[1]);
45 };
46 }
47} 44}
48 45
49# auto-generate most of the API 46$Event::DIED = sub {
50 47 warn "error in event callback: @_";
51prop_gen OBJECT_PROP => "cf::object"; 48};
52# CFAPI_OBJECT_ANIMATION?
53prop_gen PLAYER_PROP => "cf::object::player";
54
55prop_gen MAP_PROP => "cf::map";
56prop_gen ARCH_PROP => "cf::arch";
57
58# guessed hierarchies
59
60@cf::object::player::ISA = 'cf::object';
61@cf::object::map::ISA = 'cf::object';
62 49
63my %ext_pkg; 50my %ext_pkg;
64my @exts; 51my @exts;
65my @hook; 52my @hook;
66my %command; 53my %command;
54my %extcmd;
55
56#############################################################################
57# utility functions
58
59use JSON::Syck (); # TODO# replace by JSON::PC once working
60
61sub from_json($) {
62 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
63 JSON::Syck::Load $_[0]
64}
65
66sub to_json($) {
67 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
68 JSON::Syck::Dump $_[0]
69}
70
71#############################################################################
72# "new" plug-in system
73
74=head3 EVENTS AND OBJECT ATTACHMENTS
75
76=over 4
77
78=item $object->attach ($attachment, key => $value...)
79
80=item $object->detach ($attachment)
81
82Attach/detach a pre-registered attachment to an object.
83
84=item $player->attach ($attachment, key => $value...)
85
86=item $player->detach ($attachment)
87
88Attach/detach a pre-registered attachment to a player.
89
90=item $map->attach ($attachment, key => $value...)
91
92=item $map->detach ($attachment)
93
94Attach/detach a pre-registered attachment to a map.
95
96=item $bool = $object->attached ($name)
97
98=item $bool = $player->attached ($name)
99
100=item $bool = $map->attached ($name)
101
102Checks wether the named attachment is currently attached to the object.
103
104=item cf::attach_global ...
105
106Attach handlers for global events.
107
108This and all following C<attach_*>-functions expect any number of the
109following handler/hook descriptions:
110
111=over 4
112
113=item prio => $number
114
115Set the priority for all following handlers/hooks (unless overwritten
116by another C<prio> setting). Lower priority handlers get executed
117earlier. The default priority is C<0>, and many built-in handlers are
118registered at priority C<-1000>, so lower priorities should not be used
119unless you know what you are doing.
120
121=item on_I<event> => \&cb
122
123Call the given code reference whenever the named event happens (event is
124something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
125handlers are recognised generally depends on the type of object these
126handlers attach to).
127
128See F<include/eventinc.h> for the full list of events supported, and their
129class.
130
131=item package => package::
132
133Look for sub functions of the name C<< on_I<event> >> in the given
134package and register them. Only handlers for eevents supported by the
135object/class are recognised.
136
137=back
138
139=item cf::attach_to_type $object_type, $subtype, ...
140
141Attach handlers for a specific object type (e.g. TRANSPORT) and
142subtype. If C<$subtype> is zero or undef, matches all objects of the given
143type.
144
145=item cf::attach_to_objects ...
146
147Attach handlers to all objects. Do not use this except for debugging or
148very rare events, as handlers are (obviously) called for I<all> objects in
149the game.
150
151=item cf::attach_to_players ...
152
153Attach handlers to all players.
154
155=item cf::attach_to_maps ...
156
157Attach handlers to all maps.
158
159=item cf:register_attachment $name, ...
160
161Register an attachment by name through which objects can refer to this
162attachment.
163
164=item cf:register_player_attachment $name, ...
165
166Register an attachment by name through which players can refer to this
167attachment.
168
169=item cf:register_map_attachment $name, ...
170
171Register an attachment by name through which maps can refer to this
172attachment.
173
174=cut
175
176# the following variables are defined in .xs and must not be re-created
177our @CB_GLOBAL = (); # registry for all global events
178our @CB_OBJECT = (); # all objects (should not be used except in emergency)
179our @CB_PLAYER = ();
180our @CB_TYPE = (); # registry for type (cf-object class) based events
181our @CB_MAP = ();
182
183my %attachment;
184
185sub _attach_cb($\%$$$) {
186 my ($registry, $undo, $event, $prio, $cb) = @_;
187
188 use sort 'stable';
189
190 $cb = [$prio, $cb];
191
192 @{$registry->[$event]} = sort
193 { $a->[0] cmp $b->[0] }
194 @{$registry->[$event] || []}, $cb;
195
196 push @{$undo->{cb}}, [$event, $cb];
197}
198
199# attach handles attaching event callbacks
200# the only thing the caller has to do is pass the correct
201# registry (== where the callback attaches to).
202sub _attach(\@$@) {
203 my ($registry, $klass, @arg) = @_;
204
205 my $prio = 0;
206
207 my %undo = (
208 registry => $registry,
209 cb => [],
210 );
211
212 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
213
214 while (@arg) {
215 my $type = shift @arg;
216
217 if ($type eq "prio") {
218 $prio = shift @arg;
219
220 } elsif ($type eq "package") {
221 my $pkg = shift @arg;
222
223 while (my ($name, $id) = each %cb_id) {
224 if (my $cb = $pkg->can ($name)) {
225 _attach_cb $registry, %undo, $id, $prio, $cb;
226 }
227 }
228
229 } elsif (exists $cb_id{$type}) {
230 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg;
231
232 } elsif (ref $type) {
233 warn "attaching objects not supported, ignoring.\n";
234
235 } else {
236 shift @arg;
237 warn "attach argument '$type' not supported, ignoring.\n";
238 }
239 }
240
241 \%undo
242}
243
244sub _attach_attachment {
245 my ($obj, $name, %arg) = @_;
246
247 return if exists $obj->{_attachment}{$name};
248
249 my $res;
250
251 if (my $attach = $attachment{$name}) {
252 my $registry = $obj->registry;
253
254 for (@$attach) {
255 my ($klass, @attach) = @$_;
256 $res = _attach @$registry, $klass, @attach;
257 }
258
259 $obj->{$name} = \%arg;
260 } else {
261 warn "object uses attachment '$name' that is not available, postponing.\n";
262 }
263
264 $obj->{_attachment}{$name} = undef;
265
266 $res->{attachment} = $name;
267 $res
268}
269
270*cf::object::attach =
271*cf::player::attach =
272*cf::map::attach = sub {
273 my ($obj, $name, %arg) = @_;
274
275 _attach_attachment $obj, $name, %arg;
276};
277
278# all those should be optimised
279*cf::object::detach =
280*cf::player::detach =
281*cf::map::detach = sub {
282 my ($obj, $name) = @_;
283
284 delete $obj->{_attachment}{$name};
285 reattach ($obj);
286};
287
288*cf::object::attached =
289*cf::player::attached =
290*cf::map::attached = sub {
291 my ($obj, $name) = @_;
292
293 exists $obj->{_attachment}{$name}
294};
295
296sub attach_global {
297 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
298}
299
300sub attach_to_type {
301 my $type = shift;
302 my $subtype = shift;
303
304 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
305}
306
307sub attach_to_objects {
308 _attach @CB_OBJECT, KLASS_OBJECT, @_
309}
310
311sub attach_to_players {
312 _attach @CB_PLAYER, KLASS_PLAYER, @_
313}
314
315sub attach_to_maps {
316 _attach @CB_MAP, KLASS_MAP, @_
317}
318
319sub register_attachment {
320 my $name = shift;
321
322 $attachment{$name} = [[KLASS_OBJECT, @_]];
323}
324
325sub register_player_attachment {
326 my $name = shift;
327
328 $attachment{$name} = [[KLASS_PLAYER, @_]];
329}
330
331sub register_map_attachment {
332 my $name = shift;
333
334 $attachment{$name} = [[KLASS_MAP, @_]];
335}
336
337our $override;
338our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
339
340sub override {
341 $override = 1;
342 @invoke_results = ();
343}
344
345sub do_invoke {
346 my $event = shift;
347 my $callbacks = shift;
348
349 @invoke_results = ();
350
351 local $override;
352
353 for (@$callbacks) {
354 eval { &{$_->[1]} };
355
356 if ($@) {
357 warn "$@";
358 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
359 override;
360 }
361
362 return 1 if $override;
363 }
364
365 0
366}
367
368=item $bool = cf::invoke EVENT_GLOBAL_XXX, ...
369
370=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
371
372=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
373
374=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
375
376Generate a global/object/player/map-specific event with the given arguments.
377
378This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
379removed in future versions), and there is no public API to access override
380results (if you must, access C<@cf::invoke_results> directly).
381
382=back
383
384=head2 methods valid for all pointers
385
386=over 4
387
388=item $object->valid
389
390=item $player->valid
391
392=item $map->valid
393
394Just because you have a perl object does not mean that the corresponding
395C-level object still exists. If you try to access an object that has no
396valid C counterpart anymore you get an exception at runtime. This method
397can be used to test for existence of the C object part without causing an
398exception.
399
400=back
401
402=cut
403
404*cf::object::valid =
405*cf::player::valid =
406*cf::map::valid = \&cf::_valid;
407
408#############################################################################
409# object support
410
411sub instantiate {
412 my ($obj, $data) = @_;
413
414 $data = from_json $data;
415
416 for (@$data) {
417 my ($name, $args) = @$_;
418
419 $obj->attach ($name, %{$args || {} });
420 }
421}
422
423# basically do the same as instantiate, without calling instantiate
424sub reattach {
425 my ($obj) = @_;
426 my $registry = $obj->registry;
427
428 @$registry = ();
429
430 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
431
432 for my $name (keys %{ $obj->{_attachment} || {} }) {
433 if (my $attach = $attachment{$name}) {
434 for (@$attach) {
435 my ($klass, @attach) = @$_;
436 _attach @$registry, $klass, @attach;
437 }
438 } else {
439 warn "object uses attachment '$name' that is not available, postponing.\n";
440 }
441 }
442}
443
444sub object_freezer_save {
445 my ($filename, $rdata, $objs) = @_;
446
447 if (length $$rdata) {
448 warn sprintf "saving %s (%d,%d)\n",
449 $filename, length $$rdata, scalar @$objs;
450
451 if (open my $fh, ">:raw", "$filename~") {
452 chmod SAVE_MODE, $fh;
453 syswrite $fh, $$rdata;
454 close $fh;
455
456 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
457 chmod SAVE_MODE, $fh;
458 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
459 close $fh;
460 rename "$filename.pst~", "$filename.pst";
461 } else {
462 unlink "$filename.pst";
463 }
464
465 rename "$filename~", $filename;
466 } else {
467 warn "FATAL: $filename~: $!\n";
468 }
469 } else {
470 unlink $filename;
471 unlink "$filename.pst";
472 }
473}
474
475sub object_thawer_load {
476 my ($filename) = @_;
477
478 local $/;
479
480 my $av;
481
482 #TODO: use sysread etc.
483 if (open my $data, "<:raw:perlio", $filename) {
484 $data = <$data>;
485 if (open my $pst, "<:raw:perlio", "$filename.pst") {
486 $av = eval { (Storable::thaw <$pst>)->{objs} };
487 }
488 return ($data, $av);
489 }
490
491 ()
492}
493
494attach_to_objects
495 prio => -1000000,
496 on_clone => sub {
497 my ($src, $dst) = @_;
498
499 @{$dst->registry} = @{$src->registry};
500
501 %$dst = %$src;
502
503 %{$dst->{_attachment}} = %{$src->{_attachment}}
504 if exists $src->{_attachment};
505 },
506;
507
508#############################################################################
509# old plug-in events
67 510
68sub inject_event { 511sub inject_event {
69 my ($data) = @_; 512 my $extension = shift;
513 my $event_code = shift;
70 514
71 my $cb = $hook[$data->{event_code}]{$data->{extension}} 515 my $cb = $hook[$event_code]{$extension}
72 or return; 516 or return;
73 517
74 $cb->($data) 518 &$cb
75} 519}
76 520
77sub inject_global_event { 521sub inject_global_event {
78 my ($data) = @_; 522 my $event = shift;
79 523
80 my $cb = $hook[$data->{event_code}] 524 my $cb = $hook[$event]
81 or return; 525 or return;
82 526
83 $_->($data) for values %$cb; 527 List::Util::max map &$_, values %$cb
84
85 ()
86} 528}
87 529
88sub inject_command { 530sub inject_command {
89 my ($name, $obj, $params) = @_; 531 my ($name, $obj, $params) = @_;
90 532
97 539
98sub register_command { 540sub register_command {
99 my ($name, $time, $cb) = @_; 541 my ($name, $time, $cb) = @_;
100 542
101 my $caller = caller; 543 my $caller = caller;
102
103 warn "registering command '$name/$time' to '$caller'"; 544 #warn "registering command '$name/$time' to '$caller'";
104 545
105 push @{ $command{$name} }, [$time, $cb, $caller]; 546 push @{ $command{$name} }, [$time, $cb, $caller];
106 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} }; 547 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
548}
549
550sub register_extcmd {
551 my ($name, $cb) = @_;
552
553 my $caller = caller;
554 #warn "registering extcmd '$name' to '$caller'";
555
556 $extcmd{$name} = [$cb, $caller];
557}
558
559sub register {
560 my ($base, $pkg) = @_;
561
562 #TODO
107} 563}
108 564
109sub load_extension { 565sub load_extension {
110 my ($path) = @_; 566 my ($path) = @_;
111 567
112 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 568 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
113 my $base = $1; 569 my $base = $1;
114 my $pkg = $1; 570 my $pkg = $1;
115 $pkg =~ s/[^[:word:]]/_/g; 571 $pkg =~ s/[^[:word:]]/_/g;
116 $pkg = "cf::ext::$pkg"; 572 $pkg = "ext::$pkg";
117 573
118 warn "loading '$path' into '$pkg'\n"; 574 warn "loading '$path' into '$pkg'\n";
119 575
120 open my $fh, "<:utf8", $path 576 open my $fh, "<:utf8", $path
121 or die "$path: $!"; 577 or die "$path: $!";
130 or die "$path: $@"; 586 or die "$path: $@";
131 587
132 push @exts, $pkg; 588 push @exts, $pkg;
133 $ext_pkg{$base} = $pkg; 589 $ext_pkg{$base} = $pkg;
134 590
135 no strict 'refs'; 591# no strict 'refs';
136
137# @{"$pkg\::ISA"} = cf::ext::; 592# @{"$pkg\::ISA"} = ext::;
138 593
139 for my $idx (0 .. $#EVENT) { 594 register $base, $pkg;
140 if (my $ref = $pkg->can ("on_$EVENT[$idx]")) {
141 warn "registering $EVENT[$idx] hook\n";
142 $hook[$idx]{$base} = $ref;
143 }
144 }
145} 595}
146 596
147sub unload_extension { 597sub unload_extension {
148 my ($pkg) = @_; 598 my ($pkg) = @_;
149 599
150 warn "removing extension $pkg\n"; 600 warn "removing extension $pkg\n";
151 601
152 # remove hooks 602 # remove hooks
603 #TODO
153 for my $idx (0 .. $#EVENT) { 604# for my $idx (0 .. $#PLUGIN_EVENT) {
154 delete $hook[$idx]{$pkg}; 605# delete $hook[$idx]{$pkg};
155 } 606# }
156 607
157 # remove commands 608 # remove commands
158 for my $name (keys %command) { 609 for my $name (keys %command) {
159 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 610 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
160 611
165 delete $command{$name}; 616 delete $command{$name};
166 delete $COMMAND{"$name\000"}; 617 delete $COMMAND{"$name\000"};
167 } 618 }
168 } 619 }
169 620
621 # remove extcmds
622 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
623 delete $extcmd{$name};
624 }
625
626 if (my $cb = $pkg->can ("unload")) {
627 eval {
628 $cb->($pkg);
629 1
630 } or warn "$pkg unloaded, but with errors: $@";
631 }
632
170 Symbol::delete_package $pkg; 633 Symbol::delete_package $pkg;
171} 634}
172 635
173sub load_extensions { 636sub load_extensions {
174 my $LIBDIR = maps_directory "perl"; 637 my $LIBDIR = maps_directory "perl";
180 1 643 1
181 } or warn "$ext not loaded: $@"; 644 } or warn "$ext not loaded: $@";
182 } 645 }
183} 646}
184 647
648#############################################################################
649# extcmd framework, basically convert ext <msg>
650# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
651
652attach_to_players
653 on_extcmd => sub {
654 my ($pl, $buf) = @_;
655
656 my $msg = eval { from_json $buf };
657
658 if (ref $msg) {
659 if (my $cb = $extcmd{$msg->{msgtype}}) {
660 if (my %reply = $cb->[0]->($pl, $msg)) {
661 $pl->ext_reply ($msg->{msgid}, %reply);
662 }
663 }
664 } else {
665 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
666 }
667
668 cf::override;
669 },
670;
671
672#############################################################################
673# load/save/clean perl data associated with a map
674
675*cf::mapsupport::on_clean = sub {
676 my ($map) = @_;
677
678 my $path = $map->tmpname;
679 defined $path or return;
680
681 unlink "$path.pst";
682};
683
684attach_to_maps prio => -10000, package => cf::mapsupport::;
685
686#############################################################################
687# load/save perl data associated with player->ob objects
688
689sub all_objects(@) {
690 @_, map all_objects ($_->inv), @_
691}
692
693# TODO: compatibility cruft, remove when no longer needed
694attach_to_players
695 on_load => sub {
696 my ($pl, $path) = @_;
697
698 for my $o (all_objects $pl->ob) {
699 if (my $value = $o->get_ob_key_value ("_perl_data")) {
700 $o->set_ob_key_value ("_perl_data");
701
702 %$o = %{ Storable::thaw pack "H*", $value };
703 }
704 }
705 },
706;
707
708#############################################################################
709# core extensions - in perl
710
711=item cf::player::exists $login
712
713Returns true when the given account exists.
714
715=cut
716
717sub cf::player::exists($) {
718 cf::player::find $_[0]
719 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
720}
721
722=item $player->reply ($npc, $msg[, $flags])
723
724Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
725can be C<undef>. Does the right thing when the player is currently in a
726dialogue with the given NPC character.
727
728=cut
729
730# rough implementation of a future "reply" method that works
731# with dialog boxes.
732sub cf::object::player::reply($$$;$) {
733 my ($self, $npc, $msg, $flags) = @_;
734
735 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
736
737 if ($self->{record_replies}) {
738 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
739 } else {
740 $msg = $npc->name . " says: $msg" if $npc;
741 $self->message ($msg, $flags);
742 }
743}
744
745=item $player->ext_reply ($msgid, $msgtype, %msg)
746
747Sends an ext reply to the player.
748
749=cut
750
751sub cf::player::ext_reply($$$%) {
752 my ($self, $id, %msg) = @_;
753
754 $msg{msgid} = $id;
755
756 $self->send ("ext " . to_json \%msg);
757}
758
759#############################################################################
760# map scripting support
761
762our $safe = new Safe "safe";
763our $safe_hole = new Safe::Hole;
764
765$SIG{FPE} = 'IGNORE';
766
767$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
768
769# here we export the classes and methods available to script code
770
771for (
772 ["cf::object" => qw(contr pay_amount pay_player)],
773 ["cf::object::player" => qw(player)],
774 ["cf::player" => qw(peaceful)],
775) {
776 no strict 'refs';
777 my ($pkg, @funs) = @$_;
778 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
779 for @funs;
780}
781
782sub safe_eval($;@) {
783 my ($code, %vars) = @_;
784
785 my $qcode = $code;
786 $qcode =~ s/"/‟/g; # not allowed in #line filenames
787 $qcode =~ s/\n/\\n/g;
788
789 local $_;
790 local @safe::cf::_safe_eval_args = values %vars;
791
792 my $eval =
793 "do {\n"
794 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
795 . "#line 0 \"{$qcode}\"\n"
796 . $code
797 . "\n}"
798 ;
799
800 sub_generation_inc;
801 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
802 sub_generation_inc;
803
804 if ($@) {
805 warn "$@";
806 warn "while executing safe code '$code'\n";
807 warn "with arguments " . (join " ", %vars) . "\n";
808 }
809
810 wantarray ? @res : $res[0]
811}
812
813sub register_script_function {
814 my ($fun, $cb) = @_;
815
816 no strict 'refs';
817 *{"safe::$fun"} = $safe_hole->wrap ($cb);
818}
819
820#############################################################################
821
822=head2 EXTENSION DATABASE SUPPORT
823
824Crossfire maintains a very simple database for extension use. It can
825currently store anything that can be serialised using Storable, which
826excludes objects.
827
828The parameter C<$family> should best start with the name of the extension
829using it, it should be unique.
830
831=over 4
832
833=item $hashref = cf::db_get $family
834
835Return a hashref for use by the extension C<$family>, which can be
836modified. After modifications, you have to call C<cf::db_dirty> or
837C<cf::db_sync>.
838
839=item $value = cf::db_get $family => $key
840
841Returns a single value from the database
842
843=item cf::db_put $family => $hashref
844
845Stores the given family hashref into the database. Updates are delayed, if
846you want the data to be synced to disk immediately, use C<cf::db_sync>.
847
848=item cf::db_put $family => $key => $value
849
850Stores the given C<$value> in the family hash. Updates are delayed, if you
851want the data to be synced to disk immediately, use C<cf::db_sync>.
852
853=item cf::db_dirty
854
855Marks the database as dirty, to be updated at a later time.
856
857=item cf::db_sync
858
859Immediately write the database to disk I<if it is dirty>.
860
861=cut
862
863{
864 my $db;
865 my $path = cf::localdir . "/database.pst";
866
867 sub db_load() {
868 warn "loading database $path\n";#d# remove later
869 $db = stat $path ? Storable::retrieve $path : { };
870 }
871
872 my $pid;
873
874 sub db_save() {
875 warn "saving database $path\n";#d# remove later
876 waitpid $pid, 0 if $pid;
877 if (0 == ($pid = fork)) {
878 $db->{_meta}{version} = 1;
879 Storable::nstore $db, "$path~";
880 rename "$path~", $path;
881 kill 9, $$ if defined $pid; #d# remove when binary updated
882 cf::_exit 0 if defined $pid;
883 }
884 }
885
886 my $dirty;
887
888 sub db_sync() {
889 db_save if $dirty;
890 undef $dirty;
891 }
892
893 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub {
894 db_sync;
895 });
896
897 sub db_dirty() {
898 $dirty = 1;
899 $idle->start;
900 }
901
902 sub db_get($;$) {
903 @_ >= 2
904 ? $db->{$_[0]}{$_[1]}
905 : ($db->{$_[0]} ||= { })
906 }
907
908 sub db_put($$;$) {
909 if (@_ >= 3) {
910 $db->{$_[0]}{$_[1]} = $_[2];
911 } else {
912 $db->{$_[0]} = $_[1];
913 }
914 db_dirty;
915 }
916
917 attach_global
918 prio => 10000,
919 on_cleanup => sub {
920 db_sync;
921 },
922 ;
923}
924
925#############################################################################
926# the server's main()
927
928sub main {
929 db_load;
930 load_extensions;
931 Event::loop;
932}
933
934#############################################################################
935# initialisation
936
937sub _perl_reload(&) {
938 my ($msg) = @_;
939
940 $msg->("reloading...");
941
942 eval {
943 # cancel all watchers
944 $_->cancel for Event::all_watchers;
945
946 # unload all extensions
947 for (@exts) {
948 $msg->("unloading <$_>");
949 unload_extension $_;
950 }
951
952 # unload all modules loaded from $LIBDIR
953 while (my ($k, $v) = each %INC) {
954 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
955
956 $msg->("removing <$k>");
957 delete $INC{$k};
958
959 $k =~ s/\.pm$//;
960 $k =~ s/\//::/g;
961
962 if (my $cb = $k->can ("unload_module")) {
963 $cb->();
964 }
965
966 Symbol::delete_package $k;
967 }
968
969 # sync database to disk
970 cf::db_sync;
971
972 # get rid of safe::, as good as possible
973 Symbol::delete_package "safe::$_"
974 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
975
976 # remove register_script_function callbacks
977 # TODO
978
979 # unload cf.pm "a bit"
980 delete $INC{"cf.pm"};
981
982 # don't, removes xs symbols, too,
983 # and global variables created in xs
984 #Symbol::delete_package __PACKAGE__;
985
986 # reload cf.pm
987 $msg->("reloading cf.pm");
988 require cf;
989
990 # load database again
991 cf::db_load;
992
993 # load extensions
994 $msg->("load extensions");
995 cf::load_extensions;
996
997 # reattach attachments to objects
998 $msg->("reattach");
999 _global_reattach;
1000 };
1001 $msg->($@) if $@;
1002
1003 $msg->("reloaded");
1004};
1005
1006sub perl_reload() {
1007 _perl_reload {
1008 warn $_[0];
1009 print "$_[0]\n";
1010 };
1011}
1012
185register_command "perl-reload", 0, sub { 1013register_command "perl-reload", 0, sub {
186 my ($who, $arg) = @_; 1014 my ($who, $arg) = @_;
187 1015
188 if ($who->flag (FLAG_WIZ)) { 1016 if ($who->flag (FLAG_WIZ)) {
189 $who->message ("reloading..."); 1017 _perl_reload {
190 1018 warn $_[0];
191 warn "reloading...\n"; 1019 $who->message ($_[0]);
192 eval {
193 unload_extension $_ for @exts;
194 delete $INC{"cf.pm"};
195
196 # don't, removes xs symbols, too
197 #Symbol::delete_package $pkg;
198
199 require cf;
200 }; 1020 };
201 warn $@ if $@;
202 $who->message ($@) if $@;
203 warn "reloaded\n";
204
205 $who->message ("reloaded");
206 } else {
207 $who->message ("Intruder Alert!");
208 } 1021 }
209}; 1022};
210 1023
211load_extensions; 1024register "<global>", __PACKAGE__;
1025
1026unshift @INC, $LIBDIR;
1027
1028$TICK_WATCHER = Event->timer (
1029 prio => 1,
1030 at => $NEXT_TICK || 1,
1031 cb => sub {
1032 cf::server_tick; # one server iteration
1033
1034 my $NOW = Event::time;
1035 $NEXT_TICK += $TICK;
1036
1037 # if we are delayed by four ticks, skip them all
1038 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1039
1040 $TICK_WATCHER->at ($NEXT_TICK);
1041 $TICK_WATCHER->start;
1042 },
1043);
212 1044
2131 10451
214 1046

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines