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.15 by root, Sun Jun 11 15:02:16 2006 UTC vs.
Revision 1.47 by root, Sun Aug 27 13:02:04 2006 UTC

1package cf; 1package cf;
2 2
3use Symbol; 3use Symbol;
4use List::Util; 4use List::Util;
5use Storable; 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
6 13
7use strict; 14use strict;
8 15
16_reload_1;
17
9our %COMMAND; 18our %COMMAND = ();
10our @EVENT; 19our @EVENT;
11our %PROP_TYPE; 20our %PROP_TYPE;
12our %PROP_IDX; 21our %PROP_IDX;
22our $LIBDIR = maps_directory "perl";
23
24our $TICK = MAX_TIME * 1e-6;
25our $TICK_WATCHER;
26our $NEXT_TICK;
13 27
14BEGIN { 28BEGIN {
15 @EVENT = map lc, @EVENT;
16
17 *CORE::GLOBAL::warn = sub { 29 *CORE::GLOBAL::warn = sub {
18 my $msg = join "", @_; 30 my $msg = join "", @_;
19 $msg .= "\n" 31 $msg .= "\n"
20 unless $msg =~ /\n$/; 32 unless $msg =~ /\n$/;
21 33
… …
56prop_gen PLAYER_PROP => "cf::object::player"; 68prop_gen PLAYER_PROP => "cf::object::player";
57 69
58prop_gen MAP_PROP => "cf::map"; 70prop_gen MAP_PROP => "cf::map";
59prop_gen ARCH_PROP => "cf::arch"; 71prop_gen ARCH_PROP => "cf::arch";
60 72
61# guessed hierarchies 73@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
62 74
63@cf::object::player::ISA = 'cf::object'; 75# we bless all objects into (empty) derived classes to force a method lookup
64@cf::object::map::ISA = 'cf::object'; 76# within the Safe compartment.
77for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {
78 no strict 'refs';
79 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
80}
81
82$Event::DIED = sub {
83 warn "error in event callback: @_";
84};
65 85
66my %ext_pkg; 86my %ext_pkg;
67my @exts; 87my @exts;
68my @hook; 88my @hook;
69my %command; 89my %command;
70my %extcmd; 90my %extcmd;
71 91
92#############################################################################
93# utility functions
94
95use JSON::Syck (); # TODO# replace by JSON::PC once working
96
97sub from_json($) {
98 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
99 JSON::Syck::Load $_[0]
100}
101
102sub to_json($) {
103 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
104 JSON::Syck::Dump $_[0]
105}
106
107#############################################################################
108# "new" plug-in system
109
110=item $object->attach ($attachment, ...)
111
112Attach a pre-registered attachment to an object.
113
114=item $player->attach ($attachment, ...)
115
116Attach a pre-registered attachment to a player.
117
118=item $map->attach ($attachment, ...) # not yet persistent
119
120Attach a pre-registered attachment to a map.
121
122=item cf::attach_global ...
123
124Attach handlers for global events.
125
126This and all following C<attach_*>-functions expect any number of the
127following handler/hook descriptions:
128
129=over 4
130
131=item prio => $number
132
133Set the priority for all following handlers/hooks (unless overwritten
134by another C<prio> setting). Lower priority handlers get executed
135earlier. The default priority is C<0>, and many built-in handlers are
136registered at priority C<-1000>, so lower priorities should not be used
137unless you know what you are doing.
138
139=item on_I<event> => \&cb
140
141Call the given code reference whenever the named event happens (event is
142something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
143handlers are recognised generally depends on the type of object these
144handlers attach to).
145
146See F<include/eventinc.h> for the full list of events supported, and their
147class.
148
149=item package => package::
150
151Look for sub functions of the name C<< on_I<event> >> in the given
152package and register them. Only handlers for eevents supported by the
153object/class are recognised.
154
155=back
156
157=item cf::attach_to_type $object_type, $subtype, ...
158
159Attach handlers for a specific object type (e.g. TRANSPORT) and
160subtype. If C<$subtype> is zero or undef, matches all objects of the given
161type.
162
163=item cf::attach_to_objects ...
164
165Attach handlers to all objects. Do not use this except for debugging or
166very rare events, as handlers are (obviously) called for I<all> objects in
167the game.
168
169=item cf::attach_to_players ...
170
171Attach handlers to all players.
172
173=item cf::attach_to_maps ...
174
175Attach handlers to all maps.
176
177=item cf:register_attachment $name, ...
178
179=cut
180
181# the following variables are defined in .xs and must not be re-created
182our @CB_GLOBAL = (); # registry for all global events
183our @CB_OBJECT = (); # all objects (should not be used except in emergency)
184our @CB_PLAYER = ();
185our @CB_TYPE = (); # registry for type (cf-object class) based events
186our @CB_MAP = ();
187
188my %attachment;
189
190sub _attach_cb($\%$$$) {
191 my ($registry, $undo, $event, $prio, $cb) = @_;
192
193 use sort 'stable';
194
195 $cb = [$prio, $cb];
196
197 @{$registry->[$event]} = sort
198 { $a->[0] cmp $b->[0] }
199 @{$registry->[$event] || []}, $cb;
200
201 push @{$undo->{cb}}, [$event, $cb];
202}
203
204# attach handles attaching event callbacks
205# the only thing the caller has to do is pass the correct
206# registry (== where the callback attaches to).
207sub _attach(\@$@) {
208 my ($registry, $klass, @arg) = @_;
209
210 my $prio = 0;
211
212 my %undo = (
213 registry => $registry,
214 cb => [],
215 );
216
217 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
218
219 while (@arg) {
220 my $type = shift @arg;
221
222 if ($type eq "prio") {
223 $prio = shift @arg;
224
225 } elsif ($type eq "package") {
226 my $pkg = shift @arg;
227
228 while (my ($name, $id) = each %cb_id) {
229 if (my $cb = $pkg->can ($name)) {
230 _attach_cb $registry, %undo, $id, $prio, $cb;
231 }
232 }
233
234 } elsif (exists $cb_id{$type}) {
235 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg;
236
237 } elsif (ref $type) {
238 warn "attaching objects not supported, ignoring.\n";
239
240 } else {
241 shift @arg;
242 warn "attach argument '$type' not supported, ignoring.\n";
243 }
244 }
245
246 \%undo
247}
248
249sub _attach_attachment {
250 my ($obj, $name, @args) = @_;
251
252 my $res;
253
254 if (my $attach = $attachment{$name}) {
255 my $registry = $obj->registry;
256
257 for (@$attach) {
258 my ($klass, @attach) = @$_;
259 $res = _attach @$registry, $klass, @attach;
260 }
261
262 if (my $cb = delete $registry->[EVENT_OBJECT_INSTANTIATE]) {
263 for (@$cb) {
264 eval { $_->[1]->($obj, @args); };
265 if ($@) {
266 warn "$@";
267 warn "... while processing '$name' instantiate with args <@args>.\n";
268 }
269 }
270 }
271 } else {
272 warn "object uses attachment '$name' that is not available, postponing.\n";
273 }
274
275 push @{$obj->{_attachment}}, $name;
276
277 $res->{attachment} = $name;
278 $res
279}
280
281sub cf::object::attach {
282 my ($obj, $name, @args) = @_;
283
284 _attach_attachment $obj, $name, @args;
285}
286
287sub cf::player::attach {
288 my ($obj, $name, @args) = @_;
289
290 _attach_attachment KLASS_PLAYER, $obj, $name, @args;
291}
292
293sub cf::map::attach {
294 my ($obj, $name, @args) = @_;
295
296 _attach_attachment KLASS_MAP, $obj, $name, @args;
297}
298
299sub attach_global {
300 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
301}
302
303sub attach_to_type {
304 my $type = shift;
305 my $subtype = shift;
306
307 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
308}
309
310sub attach_to_objects {
311 _attach @CB_OBJECT, KLASS_OBJECT, @_
312}
313
314sub attach_to_players {
315 _attach @CB_PLAYER, KLASS_PLAYER, @_
316}
317
318sub attach_to_maps {
319 _attach @CB_MAP, KLASS_MAP, @_
320}
321
322sub register_attachment {
323 my $name = shift;
324
325 $attachment{$name} = [[KLASS_OBJECT, @_]];
326}
327
328our $override;
329our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
330
331sub override {
332 $override = 1;
333 @invoke_results = ();
334}
335
336sub do_invoke {
337 my $event = shift;
338 my $callbacks = shift;
339
340 @invoke_results = ();
341
342 local $override;
343
344 for (@$callbacks) {
345 eval { &{$_->[1]} };
346
347 if ($@) {
348 warn "$@";
349 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n";
350 override;
351 }
352
353 return 1 if $override;
354 }
355
356 0
357}
358
359#############################################################################
360# object support
361
362sub instantiate {
363 my ($obj, $data) = @_;
364
365 $data = from_json $data;
366
367 for (@$data) {
368 my ($name, $args) = @$_;
369 attach $obj, $name, @{$args || [] };
370 }
371}
372
373# basically do the same as instantiate, without calling instantiate
374sub reattach {
375 my ($obj) = @_;
376 my $registry = $obj->registry;
377
378 @$registry = ();
379
380 for my $name (@{ $obj->{_attachment} }) {
381 if (my $attach = $attachment{$name}) {
382 for (@$attach) {
383 my ($klass, @attach) = @$_;
384 _attach @$registry, $klass, @attach;
385 }
386 } else {
387 warn "object uses attachment '$name' that is not available, postponing.\n";
388 }
389 }
390}
391
392sub object_freezer_save {
393 my ($filename, $objs) = @_;
394
395 $filename .= ".pst";
396
397 if (@$objs) {
398 open my $fh, ">:raw", "$filename~";
399 chmod $fh, SAVE_MODE;
400 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
401 close $fh;
402 rename "$filename~", $filename;
403 } else {
404 unlink $filename;
405 }
406}
407
408sub object_thawer_load {
409 my ($filename) = @_;
410
411 open my $fh, "<:raw:perlio", "$filename.pst"
412 or return;
413
414 eval { local $/; (Storable::thaw <$fh>)->{objs} }
415}
416
417attach_to_objects
418 prio => -1000000,
419 on_clone => sub {
420 my ($src, $dst) = @_;
421
422 @{$dst->registry} = @{$src->registry};
423
424 %$dst = %$src;
425
426 $dst->{_attachment} = [@{ $src->{_attachment} }]
427 if exists $src->{_attachment};
428 },
429;
430
431#############################################################################
432# old plug-in events
433
72sub inject_event { 434sub inject_event {
73 my $extension = shift; 435 my $extension = shift;
74 my $event_code = shift; 436 my $event_code = shift;
75 437
76 my $cb = $hook[$event_code]{$extension} 438 my $cb = $hook[$event_code]{$extension}
… …
100 462
101sub register_command { 463sub register_command {
102 my ($name, $time, $cb) = @_; 464 my ($name, $time, $cb) = @_;
103 465
104 my $caller = caller; 466 my $caller = caller;
105
106 warn "registering command '$name/$time' to '$caller'"; 467 #warn "registering command '$name/$time' to '$caller'";
107 468
108 push @{ $command{$name} }, [$time, $cb, $caller]; 469 push @{ $command{$name} }, [$time, $cb, $caller];
109 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} }; 470 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
110} 471}
111 472
473sub register_extcmd {
474 my ($name, $cb) = @_;
475
476 my $caller = caller;
477 #warn "registering extcmd '$name' to '$caller'";
478
479 $extcmd{$name} = [$cb, $caller];
480}
481
112sub register { 482sub register {
113 my ($base, $pkg) = @_; 483 my ($base, $pkg) = @_;
114 484
115 for my $idx (0 .. $#EVENT) { 485 #TODO
116 if (my $ref = $pkg->can ("on_$EVENT[$idx]")) {
117 warn "registering $EVENT[$idx] hook to '$pkg'\n";
118 $hook[$idx]{$base} = $ref;
119 }
120 }
121} 486}
122 487
123sub load_extension { 488sub load_extension {
124 my ($path) = @_; 489 my ($path) = @_;
125 490
126 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 491 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
127 my $base = $1; 492 my $base = $1;
128 my $pkg = $1; 493 my $pkg = $1;
129 $pkg =~ s/[^[:word:]]/_/g; 494 $pkg =~ s/[^[:word:]]/_/g;
130 $pkg = "cf::ext::$pkg"; 495 $pkg = "ext::$pkg";
131 496
132 warn "loading '$path' into '$pkg'\n"; 497 warn "loading '$path' into '$pkg'\n";
133 498
134 open my $fh, "<:utf8", $path 499 open my $fh, "<:utf8", $path
135 or die "$path: $!"; 500 or die "$path: $!";
… …
145 510
146 push @exts, $pkg; 511 push @exts, $pkg;
147 $ext_pkg{$base} = $pkg; 512 $ext_pkg{$base} = $pkg;
148 513
149# no strict 'refs'; 514# no strict 'refs';
150# @{"$pkg\::ISA"} = cf::ext::; 515# @{"$pkg\::ISA"} = ext::;
151 516
152 register $base, $pkg; 517 register $base, $pkg;
153} 518}
154 519
155sub unload_extension { 520sub unload_extension {
156 my ($pkg) = @_; 521 my ($pkg) = @_;
157 522
158 warn "removing extension $pkg\n"; 523 warn "removing extension $pkg\n";
159 524
160 # remove hooks 525 # remove hooks
526 #TODO
161 for my $idx (0 .. $#EVENT) { 527# for my $idx (0 .. $#PLUGIN_EVENT) {
162 delete $hook[$idx]{$pkg}; 528# delete $hook[$idx]{$pkg};
163 } 529# }
164 530
165 # remove commands 531 # remove commands
166 for my $name (keys %command) { 532 for my $name (keys %command) {
167 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 533 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
168 534
… …
174 delete $COMMAND{"$name\000"}; 540 delete $COMMAND{"$name\000"};
175 } 541 }
176 } 542 }
177 543
178 # remove extcmds 544 # remove extcmds
179 for my $name (keys %command) { 545 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
180 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
181
182 if (@cb) {
183 $command{$name} = \@cb;
184 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
185 } else {
186 delete $command{$name}; 546 delete $extcmd{$name};
187 delete $COMMAND{"$name\000"};
188 }
189 } 547 }
190 548
549 if (my $cb = $pkg->can ("unload")) {
550 eval {
551 $cb->($pkg);
552 1
553 } or warn "$pkg unloaded, but with errors: $@";
554 }
191 555
192 Symbol::delete_package $pkg; 556 Symbol::delete_package $pkg;
193} 557}
194 558
195sub load_extensions { 559sub load_extensions {
… …
202 1 566 1
203 } or warn "$ext not loaded: $@"; 567 } or warn "$ext not loaded: $@";
204 } 568 }
205} 569}
206 570
571sub _perl_reload(&) {
572 my ($msg) = @_;
573
574 $msg->("reloading...");
575
576 eval {
577 # 1. cancel all watchers
578 $_->cancel for Event::all_watchers;
579
580 # 2. unload all extensions
581 for (@exts) {
582 $msg->("unloading <$_>");
583 unload_extension $_;
584 }
585
586 # 3. unload all modules loaded from $LIBDIR
587 while (my ($k, $v) = each %INC) {
588 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
589
590 $msg->("removing <$k>");
591 delete $INC{$k};
592
593 $k =~ s/\.pm$//;
594 $k =~ s/\//::/g;
595
596 if (my $cb = $k->can ("unload_module")) {
597 $cb->();
598 }
599
600 Symbol::delete_package $k;
601 }
602
603 # 4. get rid of safe::, as good as possible
604 Symbol::delete_package "safe::$_"
605 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
606
607 # 5. remove register_script_function callbacks
608 # TODO
609
610 # 6. unload cf.pm "a bit"
611 delete $INC{"cf.pm"};
612
613 # don't, removes xs symbols, too,
614 # and global variables created in xs
615 #Symbol::delete_package __PACKAGE__;
616
617 # 7. reload cf.pm
618 $msg->("reloading cf.pm");
619 require cf;
620 };
621 $msg->($@) if $@;
622
623 $msg->("reloaded");
624};
625
626sub perl_reload() {
627 _perl_reload {
628 warn $_[0];
629 print "$_[0]\n";
630 };
631}
632
207register_command "perl-reload", 0, sub { 633register_command "perl-reload", 0, sub {
208 my ($who, $arg) = @_; 634 my ($who, $arg) = @_;
209 635
210 if ($who->flag (FLAG_WIZ)) { 636 if ($who->flag (FLAG_WIZ)) {
211 $who->message ("reloading..."); 637 _perl_reload {
212 638 warn $_[0];
213 warn "reloading...\n"; 639 $who->message ($_[0]);
214 eval {
215 unload_extension $_ for @exts;
216 delete $INC{"cf.pm"};
217
218 # don't, removes xs symbols, too
219 #Symbol::delete_package $pkg;
220
221 require cf;
222 }; 640 };
223 warn $@ if $@;
224 $who->message ($@) if $@;
225 warn "reloaded\n";
226
227 $who->message ("reloaded");
228 } else {
229 $who->message ("Intruder Alert!");
230 } 641 }
231}; 642};
232 643
233############################################################################# 644#############################################################################
234# extcmd framework, basically convert ext <id> <pkg> arg1 args 645# extcmd framework, basically convert ext <msg>
235# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 646# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
236 647
237sub on_extcmd { 648attach_to_players
649 on_extcmd => sub {
238 my ($pl, $buf) = @_; 650 my ($pl, $buf) = @_;
239 651
240 my ($id, $pkg, $name, $data) = split / /, $buf, 4; 652 my $msg = eval { from_json $buf };
241 653
242 if (my $method = "cf::ext::$pkg"->can ("on_extcmd_$name")) { 654 if (ref $msg) {
243 $method->($pl, $id, $buf); 655 if (my $cb = $extcmd{$msg->{msgtype}}) {
656 if (my %reply = $cb->[0]->($pl, $msg)) {
657 $pl->ext_reply ($msg->{msgid}, %reply);
658 }
659 }
660 } else {
661 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
662 }
663
664 cf::override;
244 } 665 },
245} 666;
246 667
247############################################################################# 668#############################################################################
248# load/save/clean perl data associated with a map 669# load/save/clean perl data associated with a map
249 670
250*on_mapclean = sub { 671*cf::mapsupport::on_clean = sub {
251 my ($map) = @_; 672 my ($map) = @_;
252 673
253 my $path = $map->tmpname; 674 my $path = $map->tmpname;
254 defined $path or return; 675 defined $path or return;
255 676
256 unlink "$path.cfperl"; 677 unlink "$path.cfperl";
678 unlink "$path.pst";
257}; 679};
258 680
259*on_mapin = 681*cf::mapsupport::on_swapin =
260*on_mapload = sub { 682*cf::mapsupport::on_load = sub {
261 my ($map) = @_; 683 my ($map) = @_;
262 684
263 my $path = $map->tmpname; 685 my $path = $map->tmpname;
264 $path = $map->path unless defined $path; 686 $path = $map->path unless defined $path;
265 687
… …
272 or return; # too new 694 or return; # too new
273 695
274 $map->_set_obs ($data->{obs}); 696 $map->_set_obs ($data->{obs});
275}; 697};
276 698
277*on_mapout = sub { 699attach_to_maps prio => -10000, package => cf::mapsupport::;
278 my ($map) = @_;
279 700
280 my $path = $map->tmpname; 701#############################################################################
281 $path = $map->path unless defined $path; 702# load/save perl data associated with player->ob objects
282 703
283 my $obs = $map->_get_obs; 704sub all_objects(@) {
705 @_, map all_objects ($_->inv), @_
706}
284 707
285 if (defined $obs) { 708attach_to_players
286 open my $fh, ">:raw", "$path.cfperl" 709 on_load => sub {
287 or die "$path.cfperl: $!"; 710 my ($pl, $path) = @_;
288 711
289 stat $path; 712 for my $o (all_objects $pl->ob) {
713 if (my $value = $o->get_ob_key_value ("_perl_data")) {
714 $o->set_ob_key_value ("_perl_data");
290 715
291 print $fh Storable::nfreeze { 716 %$o = %{ Storable::thaw pack "H*", $value };
292 size => (stat _)[7], 717 }
293 time => (stat _)[9],
294 version => 1,
295 obs => $obs,
296 }; 718 }
719 },
720;
297 721
298 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g* 722#############################################################################
723# core extensions - in perl
724
725=item cf::player::exists $login
726
727Returns true when the given account exists.
728
729=cut
730
731sub cf::player::exists($) {
732 cf::player::find $_[0]
733 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
734}
735
736=item $player->reply ($npc, $msg[, $flags])
737
738Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
739can be C<undef>. Does the right thing when the player is currently in a
740dialogue with the given NPC character.
741
742=cut
743
744# rough implementation of a future "reply" method that works
745# with dialog boxes.
746sub cf::object::player::reply($$$;$) {
747 my ($self, $npc, $msg, $flags) = @_;
748
749 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
750
751 if ($self->{record_replies}) {
752 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
299 } else { 753 } else {
300 unlink "$path.cfperl"; 754 $msg = $npc->name . " says: $msg" if $npc;
755 $self->message ($msg, $flags);
301 } 756 }
302}; 757}
303 758
304############################################################################# 759=item $player->ext_reply ($msgid, $msgtype, %msg)
305# load/save perl data associated with player->ob objects
306 760
307*on_player_load = sub { 761Sends an ext reply to the player.
762
763=cut
764
765sub cf::player::ext_reply($$$%) {
766 my ($self, $id, %msg) = @_;
767
768 $msg{msgid} = $id;
769
770 $self->send ("ext " . to_json \%msg);
771}
772
773#############################################################################
774# map scripting support
775
776our $safe = new Safe "safe";
777our $safe_hole = new Safe::Hole;
778
779$SIG{FPE} = 'IGNORE';
780
781$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
782
783# here we export the classes and methods available to script code
784
785for (
786 ["cf::object" => qw(contr pay_amount pay_player)],
787 ["cf::object::player" => qw(player)],
788 ["cf::player" => qw(peaceful)],
789) {
790 no strict 'refs';
791 my ($pkg, @funs) = @$_;
792 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
793 for @funs;
794}
795
796sub safe_eval($;@) {
308 my ($ob, $path) = @_; 797 my ($code, %vars) = @_;
309 798
310 if (open my $fh, "<:raw", "$path.cfperl") { 799 my $qcode = $code;
800 $qcode =~ s/"/‟/g; # not allowed in #line filenames
801 $qcode =~ s/\n/\\n/g;
311 802
312 #d##TODO#remove 803 local $_;
804 local @safe::cf::_safe_eval_args = values %vars;
313 805
314 my $data = Storable::thaw do { local $/; <$fh> }; 806 my $eval =
315 807 "do {\n"
316 $data->{version} <= 1 808 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
317 or return; # too new 809 . "#line 0 \"{$qcode}\"\n"
318 810 . $code
319 %$ob = %{$data->{ob}}; 811 . "\n}"
320 return;
321 } 812 ;
322 813
323 for my $o ($ob, $ob->inv) { 814 sub_generation_inc;
324 if (my $value = $o->get_ob_key_value ("_perl_data")) { 815 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
325 $o->set_ob_key_value ("_perl_data"); 816 sub_generation_inc;
326 817
327 %$o = %{ Storable::thaw pack "H*", $value }; 818 if ($@) {
328 } 819 warn "$@";
820 warn "while executing safe code '$code'\n";
821 warn "with arguments " . (join " ", %vars) . "\n";
329 } 822 }
330};
331 823
332*on_player_save = sub { 824 wantarray ? @res : $res[0]
333 my ($ob, $path) = @_; 825}
334 826
335 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_) 827sub register_script_function {
336 for grep %$_, $ob, $ob->inv; 828 my ($fun, $cb) = @_;
337 829
338 unlink "$path.cfperl";#d##TODO#remove 830 no strict 'refs';
339}; 831 *{"safe::$fun"} = $safe_hole->wrap ($cb);
832}
833
834#############################################################################
835# the server's main()
836
837sub main {
838 Event::loop;
839}
840
841#############################################################################
842# initialisation
340 843
341register "<global>", __PACKAGE__; 844register "<global>", __PACKAGE__;
342 845
846unshift @INC, $LIBDIR;
847
343load_extensions; 848load_extensions;
344 849
850$TICK_WATCHER = Event->timer (
851 prio => 1,
852 at => $NEXT_TICK || 1,
853 cb => sub {
854 cf::server_tick; # one server iteration
855
856 my $NOW = Event::time;
857 $NEXT_TICK += $TICK;
858
859 # if we are delayed by four ticks, skip them all
860 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
861
862 $TICK_WATCHER->at ($NEXT_TICK);
863 $TICK_WATCHER->start;
864 },
865);
866
867_reload_2;
868
3451 8691
346 870

Diff Legend

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