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.51 by root, Mon Aug 28 14:05:24 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 cf::living)) {
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, key => $value...)
100 111
112Attach a pre-registered attachment to an object.
113
114=item $player->attach ($attachment, key => $value...)
115
116Attach a pre-registered attachment to a player.
117
118=item $map->attach ($attachment, key => $value...) # 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, %arg) = @_;
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 $obj->{$name} = \%arg;
263 } else {
264 warn "object uses attachment '$name' that is not available, postponing.\n";
265 }
266
267 $obj->{_attachment}{$name} = undef;
268
269 $res->{attachment} = $name;
270 $res
271}
272
180sub cf::object::attach { 273sub cf::object::attach {
181 die; 274 my ($obj, $name, %arg) = @_;
275
276 _attach_attachment $obj, $name, %arg;
277}
278
279sub cf::player::attach {
280 my ($obj, $name, %arg) = @_;
281
282 _attach_attachment KLASS_PLAYER, $obj, $name, %arg;
283}
284
285sub cf::map::attach {
286 my ($obj, $name, %arg) = @_;
287
288 _attach_attachment KLASS_MAP, $obj, $name, %arg;
182} 289}
183 290
184sub attach_global { 291sub attach_global {
185 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 292 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
186} 293}
187 294
188sub attach_type { 295sub attach_to_type {
189 my $type = shift; 296 my $type = shift;
190 _attach @{$CB_TYPE[$type]}, KLASS_MAP, @_ 297 my $subtype = shift;
298
299 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
191} 300}
192 301
193sub attach_to_objects { 302sub attach_to_objects {
194 _attach @{$CB_CLASS{cf::object::wrap::}}, KLASS_OBJECT, @_ 303 _attach @CB_OBJECT, KLASS_OBJECT, @_
195} 304}
196 305
197sub attach_to_players { 306sub attach_to_players {
198 _attach @{$CB_CLASS{cf::player::wrap::}}, KLASS_PLAYER, @_ 307 _attach @CB_PLAYER, KLASS_PLAYER, @_
199} 308}
200 309
201sub attach_to_maps { 310sub attach_to_maps {
202 _attach @{$CB_CLASS{cf::map::wrap::}}, KLASS_MAP, @_ 311 _attach @CB_MAP, KLASS_MAP, @_
312}
313
314sub register_attachment {
315 my $name = shift;
316
317 $attachment{$name} = [[KLASS_OBJECT, @_]];
203} 318}
204 319
205our $override; 320our $override;
321our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
206 322
207sub override() { 323sub override {
208 $override = 1 324 $override = 1;
325 @invoke_results = ();
209} 326}
210 327
211sub invoke { 328sub do_invoke {
212 my $event = shift; 329 my $event = shift;
330 my $callbacks = shift;
213 331
214 my @cb; 332 @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 333
227 local $override; 334 local $override;
228 335
229 for (@cb) { 336 for (@$callbacks) {
230 eval { &{$_->[1]} }; 337 eval { &{$_->[1]} };
231 338
232 if ($@) { 339 if ($@) {
233 warn "$@"; 340 warn "$@";
234 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n"; 341 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n";
… …
240 347
241 0 348 0
242} 349}
243 350
244############################################################################# 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
362 $obj->attach ($name, %{$args || {} });
363 }
364}
365
366# basically do the same as instantiate, without calling instantiate
367sub reattach {
368 my ($obj) = @_;
369 my $registry = $obj->registry;
370
371 @$registry = ();
372
373 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
374
375 for my $name (keys %{ $obj->{_attachment} || {} }) {
376 if (my $attach = $attachment{$name}) {
377 for (@$attach) {
378 my ($klass, @attach) = @$_;
379 _attach @$registry, $klass, @attach;
380 }
381 } else {
382 warn "object uses attachment '$name' that is not available, postponing.\n";
383 }
384 }
385}
386
387sub object_freezer_save {
388 my ($filename, $objs) = @_;
389
390 if (@$objs) {
391 open my $fh, ">:raw", "$filename.pst~";
392 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
393 close $fh;
394 chmod SAVE_MODE, "$filename.pst~";
395 rename "$filename.pst~", "$filename.pst";
396 } else {
397 unlink "$filename.pst";
398 }
399
400 chmod SAVE_MODE, "$filename~";
401 rename "$filename~", $filename;
402}
403
404sub object_thawer_load {
405 my ($filename) = @_;
406
407 open my $fh, "<:raw:perlio", "$filename.pst"
408 or return;
409
410 eval { local $/; (Storable::thaw <$fh>)->{objs} }
411}
412
413attach_to_objects
414 prio => -1000000,
415 on_clone => sub {
416 my ($src, $dst) = @_;
417
418 @{$dst->registry} = @{$src->registry};
419
420 %$dst = %$src;
421
422 %{$dst->{_attachment}} = %{$src->{_attachment}}
423 if exists $src->{_attachment};
424 },
425;
426
427#############################################################################
245# old plug-in events 428# old plug-in events
246 429
247sub inject_event { 430sub inject_event {
248 my $extension = shift; 431 my $extension = shift;
249 my $event_code = shift; 432 my $event_code = shift;
… …
293} 476}
294 477
295sub register { 478sub register {
296 my ($base, $pkg) = @_; 479 my ($base, $pkg) = @_;
297 480
298 for my $idx (0 .. $#PLUGIN_EVENT) { 481 #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} 482}
305 483
306sub load_extension { 484sub load_extension {
307 my ($path) = @_; 485 my ($path) = @_;
308 486
309 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 487 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
310 my $base = $1; 488 my $base = $1;
311 my $pkg = $1; 489 my $pkg = $1;
312 $pkg =~ s/[^[:word:]]/_/g; 490 $pkg =~ s/[^[:word:]]/_/g;
313 $pkg = "cf::ext::$pkg"; 491 $pkg = "ext::$pkg";
314 492
315 warn "loading '$path' into '$pkg'\n"; 493 warn "loading '$path' into '$pkg'\n";
316 494
317 open my $fh, "<:utf8", $path 495 open my $fh, "<:utf8", $path
318 or die "$path: $!"; 496 or die "$path: $!";
… …
339 my ($pkg) = @_; 517 my ($pkg) = @_;
340 518
341 warn "removing extension $pkg\n"; 519 warn "removing extension $pkg\n";
342 520
343 # remove hooks 521 # remove hooks
522 #TODO
344 for my $idx (0 .. $#PLUGIN_EVENT) { 523# for my $idx (0 .. $#PLUGIN_EVENT) {
345 delete $hook[$idx]{$pkg}; 524# delete $hook[$idx]{$pkg};
346 } 525# }
347 526
348 # remove commands 527 # remove commands
349 for my $name (keys %command) { 528 for my $name (keys %command) {
350 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 529 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
351 530
… …
361 # remove extcmds 540 # remove extcmds
362 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 541 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
363 delete $extcmd{$name}; 542 delete $extcmd{$name};
364 } 543 }
365 544
366 if (my $cb = $pkg->can ("on_unload")) { 545 if (my $cb = $pkg->can ("unload")) {
367 eval { 546 eval {
368 $cb->($pkg); 547 $cb->($pkg);
369 1 548 1
370 } or warn "$pkg unloaded, but with errors: $@"; 549 } or warn "$pkg unloaded, but with errors: $@";
371 } 550 }
… …
415 } 594 }
416 595
417 Symbol::delete_package $k; 596 Symbol::delete_package $k;
418 } 597 }
419 598
420 # 4. get rid of ext::, as good as possible 599 # 4. get rid of safe::, as good as possible
421 Symbol::delete_package "ext::$_" 600 Symbol::delete_package "safe::$_"
422 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region); 601 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
423 602
424 # 5. remove register_script_function callbacks 603 # 5. remove register_script_function callbacks
425 # TODO 604 # TODO
426 605
427 # 6. unload cf.pm "a bit" 606 # 6. unload cf.pm "a bit"
428 delete $INC{"cf.pm"}; 607 delete $INC{"cf.pm"};
429 608
430 # don't, removes xs symbols, too 609 # don't, removes xs symbols, too,
610 # and global variables created in xs
431 #Symbol::delete_package __PACKAGE__; 611 #Symbol::delete_package __PACKAGE__;
432 612
433 # 7. reload cf.pm 613 # 7. reload cf.pm
434 $msg->("reloading cf.pm"); 614 $msg->("reloading cf.pm");
435 require cf; 615 require cf;
… …
456 }; 636 };
457 } 637 }
458}; 638};
459 639
460############################################################################# 640#############################################################################
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> 641# extcmd framework, basically convert ext <msg>
477# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 642# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
478 643
479sub on_extcmd { 644attach_to_players
645 on_extcmd => sub {
480 my ($pl, $buf) = @_; 646 my ($pl, $buf) = @_;
481 647
482 my $msg = eval { from_json $buf }; 648 my $msg = eval { from_json $buf };
483 649
484 if (ref $msg) { 650 if (ref $msg) {
485 if (my $cb = $extcmd{$msg->{msgtype}}) { 651 if (my $cb = $extcmd{$msg->{msgtype}}) {
486 if (my %reply = $cb->[0]->($pl, $msg)) { 652 if (my %reply = $cb->[0]->($pl, $msg)) {
487 $pl->ext_reply ($msg->{msgid}, %reply); 653 $pl->ext_reply ($msg->{msgid}, %reply);
654 }
488 } 655 }
656 } else {
657 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
489 } 658 }
490 } else { 659
491 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 660 cf::override;
492 } 661 },
493 662;
494 1
495}
496 663
497############################################################################# 664#############################################################################
498# load/save/clean perl data associated with a map 665# load/save/clean perl data associated with a map
499 666
500*cf::mapsupport::on_clean = sub { 667*cf::mapsupport::on_clean = sub {
501 my ($map) = @_; 668 my ($map) = @_;
502 669
503 my $path = $map->tmpname; 670 my $path = $map->tmpname;
504 defined $path or return; 671 defined $path or return;
505 672
506 unlink "$path.cfperl"; 673 unlink "$path.pst";
507}; 674};
508 675
676# old style persistent data, TODO: remove #d#
509*cf::mapsupport::on_swapin = 677*cf::mapsupport::on_swapin =
510*cf::mapsupport::on_load = sub { 678*cf::mapsupport::on_load = sub {
511 my ($map) = @_; 679 my ($map) = @_;
512 680
513 my $path = $map->tmpname; 681 my $path = $map->tmpname;
… …
520 688
521 $data->{version} <= 1 689 $data->{version} <= 1
522 or return; # too new 690 or return; # too new
523 691
524 $map->_set_obs ($data->{obs}); 692 $map->_set_obs ($data->{obs});
525}; 693 $map->invoke (EVENT_MAP_UPGRADE);
526
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}; 694};
553 695
554attach_to_maps prio => -10000, package => cf::mapsupport::; 696attach_to_maps prio => -10000, package => cf::mapsupport::;
555 697
556############################################################################# 698#############################################################################
… …
569 $o->set_ob_key_value ("_perl_data"); 711 $o->set_ob_key_value ("_perl_data");
570 712
571 %$o = %{ Storable::thaw pack "H*", $value }; 713 %$o = %{ Storable::thaw pack "H*", $value };
572 } 714 }
573 } 715 }
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 }, 716 },
581; 717;
582 718
583############################################################################# 719#############################################################################
584# core extensions - in perl 720# core extensions - in perl
… …
632} 768}
633 769
634############################################################################# 770#############################################################################
635# map scripting support 771# map scripting support
636 772
637our $safe = new Safe "ext"; 773our $safe = new Safe "safe";
638our $safe_hole = new Safe::Hole; 774our $safe_hole = new Safe::Hole;
639 775
640$SIG{FPE} = 'IGNORE'; 776$SIG{FPE} = 'IGNORE';
641 777
642$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 778$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
… …
648 ["cf::object::player" => qw(player)], 784 ["cf::object::player" => qw(player)],
649 ["cf::player" => qw(peaceful)], 785 ["cf::player" => qw(peaceful)],
650) { 786) {
651 no strict 'refs'; 787 no strict 'refs';
652 my ($pkg, @funs) = @$_; 788 my ($pkg, @funs) = @$_;
653 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 789 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
654 for @funs; 790 for @funs;
655} 791}
656 792
657sub safe_eval($;@) { 793sub safe_eval($;@) {
658 my ($code, %vars) = @_; 794 my ($code, %vars) = @_;
… …
660 my $qcode = $code; 796 my $qcode = $code;
661 $qcode =~ s/"/‟/g; # not allowed in #line filenames 797 $qcode =~ s/"/‟/g; # not allowed in #line filenames
662 $qcode =~ s/\n/\\n/g; 798 $qcode =~ s/\n/\\n/g;
663 799
664 local $_; 800 local $_;
665 local @ext::cf::_safe_eval_args = values %vars; 801 local @safe::cf::_safe_eval_args = values %vars;
666 802
667 $code = 803 my $eval =
668 "do {\n" 804 "do {\n"
669 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 805 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
670 . "#line 0 \"{$qcode}\"\n" 806 . "#line 0 \"{$qcode}\"\n"
671 . $code 807 . $code
672 . "\n}" 808 . "\n}"
673 ; 809 ;
674 810
675 sub_generation_inc; 811 sub_generation_inc;
676 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 812 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
677 sub_generation_inc; 813 sub_generation_inc;
814
815 if ($@) {
816 warn "$@";
817 warn "while executing safe code '$code'\n";
818 warn "with arguments " . (join " ", %vars) . "\n";
819 }
678 820
679 wantarray ? @res : $res[0] 821 wantarray ? @res : $res[0]
680} 822}
681 823
682sub register_script_function { 824sub register_script_function {
683 my ($fun, $cb) = @_; 825 my ($fun, $cb) = @_;
684 826
685 no strict 'refs'; 827 no strict 'refs';
686 *{"ext::$fun"} = $safe_hole->wrap ($cb); 828 *{"safe::$fun"} = $safe_hole->wrap ($cb);
687} 829}
688 830
689############################################################################# 831#############################################################################
690# the server's main() 832# the server's main()
691 833
… …
717 $TICK_WATCHER->at ($NEXT_TICK); 859 $TICK_WATCHER->at ($NEXT_TICK);
718 $TICK_WATCHER->start; 860 $TICK_WATCHER->start;
719 }, 861 },
720); 862);
721 863
864_reload_2;
865
7221 8661
723 867

Diff Legend

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