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.39 by root, Fri Aug 25 13:24:50 2006 UTC vs.
Revision 1.47 by root, Sun Aug 27 13:02:04 2006 UTC

… …
11use Event; 11use Event;
12$Event::Eval = 1; # no idea why this is required, but it is 12$Event::Eval = 1; # no idea why this is required, but it is
13 13
14use strict; 14use strict;
15 15
16_reload_1;
17
16our %COMMAND = (); 18our %COMMAND = ();
17our @EVENT; 19our @EVENT;
18our @PLUGIN_EVENT;
19our %PROP_TYPE; 20our %PROP_TYPE;
20our %PROP_IDX; 21our %PROP_IDX;
21our $LIBDIR = maps_directory "perl"; 22our $LIBDIR = maps_directory "perl";
22 23
23our $TICK = MAX_TIME * 1e-6; 24our $TICK = MAX_TIME * 1e-6;
24our $TICK_WATCHER; 25our $TICK_WATCHER;
25our $NEXT_TICK; 26our $NEXT_TICK;
26 27
27BEGIN { 28BEGIN {
28 @PLUGIN_EVENT = map lc, @PLUGIN_EVENT;
29
30 *CORE::GLOBAL::warn = sub { 29 *CORE::GLOBAL::warn = sub {
31 my $msg = join "", @_; 30 my $msg = join "", @_;
32 $msg .= "\n" 31 $msg .= "\n"
33 unless $msg =~ /\n$/; 32 unless $msg =~ /\n$/;
34 33
… …
69prop_gen PLAYER_PROP => "cf::object::player"; 68prop_gen PLAYER_PROP => "cf::object::player";
70 69
71prop_gen MAP_PROP => "cf::map"; 70prop_gen MAP_PROP => "cf::map";
72prop_gen ARCH_PROP => "cf::arch"; 71prop_gen ARCH_PROP => "cf::arch";
73 72
74# guessed hierarchies
75
76@ext::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 73@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
77@ext::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
78 74
79# we bless all objects into derived classes to force a method lookup 75# we bless all objects into (empty) derived classes to force a method lookup
80# within the Safe compartment. 76# 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)) { 77for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {
82 no strict 'refs'; 78 no strict 'refs';
83 @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 79 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
84} 80}
85 81
86$Event::DIED = sub { 82$Event::DIED = sub {
87 warn "error in event callback: @_"; 83 warn "error in event callback: @_";
88}; 84};
… …
92my @hook; 88my @hook;
93my %command; 89my %command;
94my %extcmd; 90my %extcmd;
95 91
96############################################################################# 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#############################################################################
97# "new" plug-in system 108# "new" plug-in system
98 109
99=item cf::object::attach ... # NYI 110=item $object->attach ($attachment, ...)
100 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
101=item cf::attach_global ... # NYI 122=item cf::attach_global ...
102 123
103=item cf::attach_to_type ... # NYI 124Attach handlers for global events.
104 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
105=item cf::attach_to_objects ... # NYI 163=item cf::attach_to_objects ...
106 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
107=item cf::attach_to_players ... # NYI 169=item cf::attach_to_players ...
108 170
171Attach handlers to all players.
172
109=item cf::attach_to_maps ... # NYI 173=item cf::attach_to_maps ...
110 174
111 prio => $number, # higehr is earlier 175Attach handlers to all maps.
112 on_xxx => \&cb, 176
113 package => package::, 177=item cf:register_attachment $name, ...
114 178
115=cut 179=cut
116 180
117our %CB_CLASS = (); # registry for class-based events 181# the following variables are defined in .xs and must not be re-created
118our @CB_GLOBAL = (); # registry for all global events 182our @CB_GLOBAL = (); # registry for all global events
183our @CB_OBJECT = (); # all objects (should not be used except in emergency)
184our @CB_PLAYER = ();
119our @CB_TYPE = (); # registry for type (cf-object class) based events 185our @CB_TYPE = (); # registry for type (cf-object class) based events
186our @CB_MAP = ();
187
188my %attachment;
120 189
121sub _attach_cb($\%$$$) { 190sub _attach_cb($\%$$$) {
122 my ($registry, $undo, $event, $prio, $cb) = @_; 191 my ($registry, $undo, $event, $prio, $cb) = @_;
123 192
124 use sort 'stable'; 193 use sort 'stable';
… …
133} 202}
134 203
135# attach handles attaching event callbacks 204# attach handles attaching event callbacks
136# the only thing the caller has to do is pass the correct 205# the only thing the caller has to do is pass the correct
137# registry (== where the callback attaches to). 206# registry (== where the callback attaches to).
138sub _attach(\@$\@) { 207sub _attach(\@$@) {
139 my ($registry, $klass, $arg) = @_; 208 my ($registry, $klass, @arg) = @_;
140 209
141 my $prio = 0; 210 my $prio = 0;
142 211
143 my %undo = ( 212 my %undo = (
144 registry => $registry, 213 registry => $registry,
145 cb => [], 214 cb => [],
146 ); 215 );
147 216
148 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; 217 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
149 218
150 while (@$arg) { 219 while (@arg) {
151 my $type = shift @$arg; 220 my $type = shift @arg;
152 221
153 if ($type eq "prio") { 222 if ($type eq "prio") {
154 $prio = shift @$arg; 223 $prio = shift @arg;
155 224
156 } elsif ($type eq "package") { 225 } elsif ($type eq "package") {
157 my $pkg = shift @$arg; 226 my $pkg = shift @arg;
158 227
159 while (my ($name, $id) = each %cb_id) { 228 while (my ($name, $id) = each %cb_id) {
160 if (my $cb = $pkg->can ($name)) { 229 if (my $cb = $pkg->can ($name)) {
161 _attach_cb $registry, %undo, $id, $prio, $cb; 230 _attach_cb $registry, %undo, $id, $prio, $cb;
162 } 231 }
163 } 232 }
164 233
165 } elsif (exists $cb_id{$type}) { 234 } elsif (exists $cb_id{$type}) {
166 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @$arg; 235 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg;
167 236
168 } elsif (ref $type) { 237 } elsif (ref $type) {
169 warn "attaching objects not supported, ignoring.\n"; 238 warn "attaching objects not supported, ignoring.\n";
170 239
171 } else { 240 } else {
172 shift @$arg; 241 shift @arg;
173 warn "attach argument '$type' not supported, ignoring.\n"; 242 warn "attach argument '$type' not supported, ignoring.\n";
174 } 243 }
175 } 244 }
176 245
177 \%undo 246 \%undo
178} 247}
179 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
180sub cf::object::attach { 281sub cf::object::attach {
181 die; 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;
182} 297}
183 298
184sub attach_global { 299sub attach_global {
185 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 300 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
186} 301}
187 302
188sub attach_type { 303sub attach_to_type {
189 my $type = shift; 304 my $type = shift;
190 _attach @{$CB_TYPE[$type]}, KLASS_MAP, @_ 305 my $subtype = shift;
306
307 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
191} 308}
192 309
193sub attach_to_objects { 310sub attach_to_objects {
194 _attach @{$CB_CLASS{cf::object::wrap::}}, KLASS_OBJECT, @_ 311 _attach @CB_OBJECT, KLASS_OBJECT, @_
195} 312}
196 313
197sub attach_to_players { 314sub attach_to_players {
198 _attach @{$CB_CLASS{cf::player::wrap::}}, KLASS_PLAYER, @_ 315 _attach @CB_PLAYER, KLASS_PLAYER, @_
199} 316}
200 317
201sub attach_to_maps { 318sub attach_to_maps {
202 _attach @{$CB_CLASS{cf::map::wrap::}}, KLASS_MAP, @_ 319 _attach @CB_MAP, KLASS_MAP, @_
320}
321
322sub register_attachment {
323 my $name = shift;
324
325 $attachment{$name} = [[KLASS_OBJECT, @_]];
203} 326}
204 327
205our $override; 328our $override;
329our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
206 330
207sub override() { 331sub override {
208 $override = 1 332 $override = 1;
333 @invoke_results = ();
209} 334}
210 335
211sub invoke { 336sub do_invoke {
212 my $event = shift; 337 my $event = shift;
338 my $callbacks = shift;
213 339
214 my @cb; 340 @invoke_results = ();
215
216 if (my $ref = ref $_[0]) {
217 # 1. object-specific (NYI)
218 # 2. class-specific
219 push @cb, @{$CB_CLASS{$ref}[$event] || []};
220 }
221
222 # global
223 push @cb, @{$CB_GLOBAL[$event] || []};
224
225# warn "invoke id $EVENT[$event][0], args <@_> <=> @cb\n";#d#
226 341
227 local $override; 342 local $override;
228 343
229 for (@cb) { 344 for (@$callbacks) {
230 eval { &{$_->[1]} }; 345 eval { &{$_->[1]} };
231 346
232 if ($@) { 347 if ($@) {
233 warn "$@"; 348 warn "$@";
234 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n"; 349 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n";
… …
240 355
241 0 356 0
242} 357}
243 358
244############################################################################# 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#############################################################################
245# old plug-in events 432# old plug-in events
246 433
247sub inject_event { 434sub inject_event {
248 my $extension = shift; 435 my $extension = shift;
249 my $event_code = shift; 436 my $event_code = shift;
… …
293} 480}
294 481
295sub register { 482sub register {
296 my ($base, $pkg) = @_; 483 my ($base, $pkg) = @_;
297 484
298 for my $idx (0 .. $#PLUGIN_EVENT) { 485 #TODO
299 if (my $ref = $pkg->can ("on_$PLUGIN_EVENT[$idx]")) {
300 #warn "registering $PLUGIN_EVENT[$idx] hook to '$pkg'\n";
301 $hook[$idx]{$base} = $ref;
302 }
303 }
304} 486}
305 487
306sub load_extension { 488sub load_extension {
307 my ($path) = @_; 489 my ($path) = @_;
308 490
309 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 491 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
310 my $base = $1; 492 my $base = $1;
311 my $pkg = $1; 493 my $pkg = $1;
312 $pkg =~ s/[^[:word:]]/_/g; 494 $pkg =~ s/[^[:word:]]/_/g;
313 $pkg = "cf::ext::$pkg"; 495 $pkg = "ext::$pkg";
314 496
315 warn "loading '$path' into '$pkg'\n"; 497 warn "loading '$path' into '$pkg'\n";
316 498
317 open my $fh, "<:utf8", $path 499 open my $fh, "<:utf8", $path
318 or die "$path: $!"; 500 or die "$path: $!";
… …
339 my ($pkg) = @_; 521 my ($pkg) = @_;
340 522
341 warn "removing extension $pkg\n"; 523 warn "removing extension $pkg\n";
342 524
343 # remove hooks 525 # remove hooks
526 #TODO
344 for my $idx (0 .. $#PLUGIN_EVENT) { 527# for my $idx (0 .. $#PLUGIN_EVENT) {
345 delete $hook[$idx]{$pkg}; 528# delete $hook[$idx]{$pkg};
346 } 529# }
347 530
348 # remove commands 531 # remove commands
349 for my $name (keys %command) { 532 for my $name (keys %command) {
350 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 533 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
351 534
… …
361 # remove extcmds 544 # remove extcmds
362 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 545 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
363 delete $extcmd{$name}; 546 delete $extcmd{$name};
364 } 547 }
365 548
366 if (my $cb = $pkg->can ("on_unload")) { 549 if (my $cb = $pkg->can ("unload")) {
367 eval { 550 eval {
368 $cb->($pkg); 551 $cb->($pkg);
369 1 552 1
370 } or warn "$pkg unloaded, but with errors: $@"; 553 } or warn "$pkg unloaded, but with errors: $@";
371 } 554 }
… …
415 } 598 }
416 599
417 Symbol::delete_package $k; 600 Symbol::delete_package $k;
418 } 601 }
419 602
420 # 4. get rid of ext::, as good as possible 603 # 4. get rid of safe::, as good as possible
421 Symbol::delete_package "ext::$_" 604 Symbol::delete_package "safe::$_"
422 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region); 605 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
423 606
424 # 5. remove register_script_function callbacks 607 # 5. remove register_script_function callbacks
425 # TODO 608 # TODO
426 609
427 # 6. unload cf.pm "a bit" 610 # 6. unload cf.pm "a bit"
428 delete $INC{"cf.pm"}; 611 delete $INC{"cf.pm"};
429 612
430 # don't, removes xs symbols, too 613 # don't, removes xs symbols, too,
614 # and global variables created in xs
431 #Symbol::delete_package __PACKAGE__; 615 #Symbol::delete_package __PACKAGE__;
432 616
433 # 7. reload cf.pm 617 # 7. reload cf.pm
434 $msg->("reloading cf.pm"); 618 $msg->("reloading cf.pm");
435 require cf; 619 require cf;
… …
456 }; 640 };
457 } 641 }
458}; 642};
459 643
460############################################################################# 644#############################################################################
461# utility functions
462
463use JSON::Syck (); # TODO# replace by JSON::PC once working
464
465sub from_json($) {
466 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
467 JSON::Syck::Load $_[0]
468}
469
470sub to_json($) {
471 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
472 JSON::Syck::Dump $_[0]
473}
474
475#############################################################################
476# extcmd framework, basically convert ext <msg> 645# extcmd framework, basically convert ext <msg>
477# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 646# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
478 647
479sub on_extcmd { 648attach_to_players
649 on_extcmd => sub {
480 my ($pl, $buf) = @_; 650 my ($pl, $buf) = @_;
481 651
482 my $msg = eval { from_json $buf }; 652 my $msg = eval { from_json $buf };
483 653
484 if (ref $msg) { 654 if (ref $msg) {
485 if (my $cb = $extcmd{$msg->{msgtype}}) { 655 if (my $cb = $extcmd{$msg->{msgtype}}) {
486 if (my %reply = $cb->[0]->($pl, $msg)) { 656 if (my %reply = $cb->[0]->($pl, $msg)) {
487 $pl->ext_reply ($msg->{msgid}, %reply); 657 $pl->ext_reply ($msg->{msgid}, %reply);
658 }
488 } 659 }
489 }
490 } else { 660 } else {
491 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 661 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
662 }
663
664 cf::override;
492 } 665 },
493 666;
494 1
495}
496 667
497############################################################################# 668#############################################################################
498# load/save/clean perl data associated with a map 669# load/save/clean perl data associated with a map
499 670
500*cf::mapsupport::on_clean = sub { 671*cf::mapsupport::on_clean = sub {
… …
502 673
503 my $path = $map->tmpname; 674 my $path = $map->tmpname;
504 defined $path or return; 675 defined $path or return;
505 676
506 unlink "$path.cfperl"; 677 unlink "$path.cfperl";
678 unlink "$path.pst";
507}; 679};
508 680
509*cf::mapsupport::on_swapin = 681*cf::mapsupport::on_swapin =
510*cf::mapsupport::on_load = sub { 682*cf::mapsupport::on_load = sub {
511 my ($map) = @_; 683 my ($map) = @_;
… …
522 or return; # too new 694 or return; # too new
523 695
524 $map->_set_obs ($data->{obs}); 696 $map->_set_obs ($data->{obs});
525}; 697};
526 698
527*cf::mapsupport::on_swapout = sub {
528 my ($map) = @_;
529
530 my $path = $map->tmpname;
531 $path = $map->path unless defined $path;
532
533 my $obs = $map->_get_obs;
534
535 if (defined $obs) {
536 open my $fh, ">:raw", "$path.cfperl"
537 or die "$path.cfperl: $!";
538
539 stat $path;
540
541 print $fh Storable::nfreeze {
542 size => (stat _)[7],
543 time => (stat _)[9],
544 version => 1,
545 obs => $obs,
546 };
547
548 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
549 } else {
550 unlink "$path.cfperl";
551 }
552};
553
554attach_to_maps prio => -10000, package => cf::mapsupport::; 699attach_to_maps prio => -10000, package => cf::mapsupport::;
555 700
556############################################################################# 701#############################################################################
557# load/save perl data associated with player->ob objects 702# load/save perl data associated with player->ob objects
558 703
… …
569 $o->set_ob_key_value ("_perl_data"); 714 $o->set_ob_key_value ("_perl_data");
570 715
571 %$o = %{ Storable::thaw pack "H*", $value }; 716 %$o = %{ Storable::thaw pack "H*", $value };
572 } 717 }
573 } 718 }
574 },
575 on_save => sub {
576 my ($pl, $path) = @_;
577
578 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
579 for grep %$_, all_objects $pl->ob;
580 }, 719 },
581; 720;
582 721
583############################################################################# 722#############################################################################
584# core extensions - in perl 723# core extensions - in perl
… …
632} 771}
633 772
634############################################################################# 773#############################################################################
635# map scripting support 774# map scripting support
636 775
637our $safe = new Safe "ext"; 776our $safe = new Safe "safe";
638our $safe_hole = new Safe::Hole; 777our $safe_hole = new Safe::Hole;
639 778
640$SIG{FPE} = 'IGNORE'; 779$SIG{FPE} = 'IGNORE';
641 780
642$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 781$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
… …
648 ["cf::object::player" => qw(player)], 787 ["cf::object::player" => qw(player)],
649 ["cf::player" => qw(peaceful)], 788 ["cf::player" => qw(peaceful)],
650) { 789) {
651 no strict 'refs'; 790 no strict 'refs';
652 my ($pkg, @funs) = @$_; 791 my ($pkg, @funs) = @$_;
653 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 792 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
654 for @funs; 793 for @funs;
655} 794}
656 795
657sub safe_eval($;@) { 796sub safe_eval($;@) {
658 my ($code, %vars) = @_; 797 my ($code, %vars) = @_;
… …
660 my $qcode = $code; 799 my $qcode = $code;
661 $qcode =~ s/"/‟/g; # not allowed in #line filenames 800 $qcode =~ s/"/‟/g; # not allowed in #line filenames
662 $qcode =~ s/\n/\\n/g; 801 $qcode =~ s/\n/\\n/g;
663 802
664 local $_; 803 local $_;
665 local @ext::cf::_safe_eval_args = values %vars; 804 local @safe::cf::_safe_eval_args = values %vars;
666 805
667 $code = 806 my $eval =
668 "do {\n" 807 "do {\n"
669 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 808 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
670 . "#line 0 \"{$qcode}\"\n" 809 . "#line 0 \"{$qcode}\"\n"
671 . $code 810 . $code
672 . "\n}" 811 . "\n}"
673 ; 812 ;
674 813
675 sub_generation_inc; 814 sub_generation_inc;
676 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 815 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
677 sub_generation_inc; 816 sub_generation_inc;
817
818 if ($@) {
819 warn "$@";
820 warn "while executing safe code '$code'\n";
821 warn "with arguments " . (join " ", %vars) . "\n";
822 }
678 823
679 wantarray ? @res : $res[0] 824 wantarray ? @res : $res[0]
680} 825}
681 826
682sub register_script_function { 827sub register_script_function {
683 my ($fun, $cb) = @_; 828 my ($fun, $cb) = @_;
684 829
685 no strict 'refs'; 830 no strict 'refs';
686 *{"ext::$fun"} = $safe_hole->wrap ($cb); 831 *{"safe::$fun"} = $safe_hole->wrap ($cb);
687} 832}
688 833
689############################################################################# 834#############################################################################
690# the server's main() 835# the server's main()
691 836
… …
717 $TICK_WATCHER->at ($NEXT_TICK); 862 $TICK_WATCHER->at ($NEXT_TICK);
718 $TICK_WATCHER->start; 863 $TICK_WATCHER->start;
719 }, 864 },
720); 865);
721 866
867_reload_2;
868
7221 8691
723 870

Diff Legend

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