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

Diff Legend

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