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.46 by root, Sun Aug 27 16:15:12 2006 UTC

… …
13 13
14use strict; 14use strict;
15 15
16our %COMMAND = (); 16our %COMMAND = ();
17our @EVENT; 17our @EVENT;
18our @PLUGIN_EVENT;
19our %PROP_TYPE; 18our %PROP_TYPE;
20our %PROP_IDX; 19our %PROP_IDX;
21our $LIBDIR = maps_directory "perl"; 20our $LIBDIR = maps_directory "perl";
22 21
23our $TICK = MAX_TIME * 1e-6; 22our $TICK = MAX_TIME * 1e-6;
24our $TICK_WATCHER; 23our $TICK_WATCHER;
25our $NEXT_TICK; 24our $NEXT_TICK;
26 25
27BEGIN { 26BEGIN {
28 @PLUGIN_EVENT = map lc, @PLUGIN_EVENT;
29
30 *CORE::GLOBAL::warn = sub { 27 *CORE::GLOBAL::warn = sub {
31 my $msg = join "", @_; 28 my $msg = join "", @_;
32 $msg .= "\n" 29 $msg .= "\n"
33 unless $msg =~ /\n$/; 30 unless $msg =~ /\n$/;
34 31
… …
69prop_gen PLAYER_PROP => "cf::object::player"; 66prop_gen PLAYER_PROP => "cf::object::player";
70 67
71prop_gen MAP_PROP => "cf::map"; 68prop_gen MAP_PROP => "cf::map";
72prop_gen ARCH_PROP => "cf::arch"; 69prop_gen ARCH_PROP => "cf::arch";
73 70
74# guessed hierarchies
75
76@ext::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 71@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
77@ext::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
78 72
79# we bless all objects into derived classes to force a method lookup 73# we bless all objects into (empty) derived classes to force a method lookup
80# within the Safe compartment. 74# 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)) { 75for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {
82 no strict 'refs'; 76 no strict 'refs';
83 @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 77 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
84} 78}
85 79
86$Event::DIED = sub { 80$Event::DIED = sub {
87 warn "error in event callback: @_"; 81 warn "error in event callback: @_";
88}; 82};
… …
92my @hook; 86my @hook;
93my %command; 87my %command;
94my %extcmd; 88my %extcmd;
95 89
96############################################################################# 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#############################################################################
97# "new" plug-in system 106# "new" plug-in system
98 107
99=item cf::object::attach ... # NYI 108=item $object->attach ($attachment, ...)
100 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
101=item cf::attach_global ... # NYI 120=item cf::attach_global ...
102 121
103=item cf::attach_to_type ... # NYI 122Attach handlers for global events.
104 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
105=item cf::attach_to_objects ... # NYI 159=item cf::attach_to_objects ...
106 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
107=item cf::attach_to_players ... # NYI 165=item cf::attach_to_players ...
108 166
167Attach handlers to all players.
168
109=item cf::attach_to_maps ... # NYI 169=item cf::attach_to_maps ...
110 170
111 prio => $number, # higehr is earlier 171Attach handlers to all maps.
112 on_xxx => \&cb, 172
113 package => package::, 173=item cf:register_attachment $name, ...
114 174
115=cut 175=cut
116 176
117our %CB_CLASS = (); # registry for class-based events 177# the following variables are defined in .xs and must not be re-created
118our @CB_GLOBAL = (); # registry for all global events 178our @CB_GLOBAL = (); # registry for all global events
179our @CB_OBJECT = (); # all objects (should not be used except in emergency)
180our @CB_PLAYER = ();
119our @CB_TYPE = (); # registry for type (cf-object class) based events 181our @CB_TYPE = (); # registry for type (cf-object class) based events
182our @CB_MAP = ();
183
184my %attachment;
120 185
121sub _attach_cb($\%$$$) { 186sub _attach_cb($\%$$$) {
122 my ($registry, $undo, $event, $prio, $cb) = @_; 187 my ($registry, $undo, $event, $prio, $cb) = @_;
123 188
124 use sort 'stable'; 189 use sort 'stable';
… …
133} 198}
134 199
135# attach handles attaching event callbacks 200# attach handles attaching event callbacks
136# the only thing the caller has to do is pass the correct 201# the only thing the caller has to do is pass the correct
137# registry (== where the callback attaches to). 202# registry (== where the callback attaches to).
138sub _attach(\@$\@) { 203sub _attach(\@$@) {
139 my ($registry, $klass, $arg) = @_; 204 my ($registry, $klass, @arg) = @_;
140 205
141 my $prio = 0; 206 my $prio = 0;
142 207
143 my %undo = ( 208 my %undo = (
144 registry => $registry, 209 registry => $registry,
145 cb => [], 210 cb => [],
146 ); 211 );
147 212
148 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; 213 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
149 214
150 while (@$arg) { 215 while (@arg) {
151 my $type = shift @$arg; 216 my $type = shift @arg;
152 217
153 if ($type eq "prio") { 218 if ($type eq "prio") {
154 $prio = shift @$arg; 219 $prio = shift @arg;
155 220
156 } elsif ($type eq "package") { 221 } elsif ($type eq "package") {
157 my $pkg = shift @$arg; 222 my $pkg = shift @arg;
158 223
159 while (my ($name, $id) = each %cb_id) { 224 while (my ($name, $id) = each %cb_id) {
160 if (my $cb = $pkg->can ($name)) { 225 if (my $cb = $pkg->can ($name)) {
161 _attach_cb $registry, %undo, $id, $prio, $cb; 226 _attach_cb $registry, %undo, $id, $prio, $cb;
162 } 227 }
163 } 228 }
164 229
165 } elsif (exists $cb_id{$type}) { 230 } elsif (exists $cb_id{$type}) {
166 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @$arg; 231 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg;
167 232
168 } elsif (ref $type) { 233 } elsif (ref $type) {
169 warn "attaching objects not supported, ignoring.\n"; 234 warn "attaching objects not supported, ignoring.\n";
170 235
171 } else { 236 } else {
172 shift @$arg; 237 shift @arg;
173 warn "attach argument '$type' not supported, ignoring.\n"; 238 warn "attach argument '$type' not supported, ignoring.\n";
174 } 239 }
175 } 240 }
176 241
177 \%undo 242 \%undo
178} 243}
179 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
180sub cf::object::attach { 274sub cf::object::attach {
181 die; 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;
182} 290}
183 291
184sub attach_global { 292sub attach_global {
185 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 293 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
186} 294}
187 295
188sub attach_type { 296sub attach_to_type {
189 my $type = shift; 297 my $type = shift;
298
190 _attach @{$CB_TYPE[$type]}, KLASS_MAP, @_ 299 _attach @{$CB_TYPE[$type]}, 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} = [@_];
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 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#############################################################################
245# old plug-in events 429# old plug-in events
246 430
247sub inject_event { 431sub inject_event {
248 my $extension = shift; 432 my $extension = shift;
249 my $event_code = shift; 433 my $event_code = shift;
… …
293} 477}
294 478
295sub register { 479sub register {
296 my ($base, $pkg) = @_; 480 my ($base, $pkg) = @_;
297 481
298 for my $idx (0 .. $#PLUGIN_EVENT) { 482 #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} 483}
305 484
306sub load_extension { 485sub load_extension {
307 my ($path) = @_; 486 my ($path) = @_;
308 487
309 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 488 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
310 my $base = $1; 489 my $base = $1;
311 my $pkg = $1; 490 my $pkg = $1;
312 $pkg =~ s/[^[:word:]]/_/g; 491 $pkg =~ s/[^[:word:]]/_/g;
313 $pkg = "cf::ext::$pkg"; 492 $pkg = "ext::$pkg";
314 493
315 warn "loading '$path' into '$pkg'\n"; 494 warn "loading '$path' into '$pkg'\n";
316 495
317 open my $fh, "<:utf8", $path 496 open my $fh, "<:utf8", $path
318 or die "$path: $!"; 497 or die "$path: $!";
… …
339 my ($pkg) = @_; 518 my ($pkg) = @_;
340 519
341 warn "removing extension $pkg\n"; 520 warn "removing extension $pkg\n";
342 521
343 # remove hooks 522 # remove hooks
523 #TODO
344 for my $idx (0 .. $#PLUGIN_EVENT) { 524# for my $idx (0 .. $#PLUGIN_EVENT) {
345 delete $hook[$idx]{$pkg}; 525# delete $hook[$idx]{$pkg};
346 } 526# }
347 527
348 # remove commands 528 # remove commands
349 for my $name (keys %command) { 529 for my $name (keys %command) {
350 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 530 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
351 531
… …
361 # remove extcmds 541 # remove extcmds
362 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 542 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
363 delete $extcmd{$name}; 543 delete $extcmd{$name};
364 } 544 }
365 545
366 if (my $cb = $pkg->can ("on_unload")) { 546 if (my $cb = $pkg->can ("unload")) {
367 eval { 547 eval {
368 $cb->($pkg); 548 $cb->($pkg);
369 1 549 1
370 } or warn "$pkg unloaded, but with errors: $@"; 550 } or warn "$pkg unloaded, but with errors: $@";
371 } 551 }
… …
415 } 595 }
416 596
417 Symbol::delete_package $k; 597 Symbol::delete_package $k;
418 } 598 }
419 599
420 # 4. get rid of ext::, as good as possible 600 # 4. get rid of safe::, as good as possible
421 Symbol::delete_package "ext::$_" 601 Symbol::delete_package "safe::$_"
422 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region); 602 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
423 603
424 # 5. remove register_script_function callbacks 604 # 5. remove register_script_function callbacks
425 # TODO 605 # TODO
426 606
427 # 6. unload cf.pm "a bit" 607 # 6. unload cf.pm "a bit"
428 delete $INC{"cf.pm"}; 608 delete $INC{"cf.pm"};
429 609
430 # don't, removes xs symbols, too 610 # don't, removes xs symbols, too,
611 # and global variables created in xs
431 #Symbol::delete_package __PACKAGE__; 612 #Symbol::delete_package __PACKAGE__;
432 613
433 # 7. reload cf.pm 614 # 7. reload cf.pm
434 $msg->("reloading cf.pm"); 615 $msg->("reloading cf.pm");
435 require cf; 616 require cf;
… …
456 }; 637 };
457 } 638 }
458}; 639};
459 640
460############################################################################# 641#############################################################################
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> 642# extcmd framework, basically convert ext <msg>
477# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 643# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
478 644
479sub on_extcmd { 645attach_to_players
646 on_extcmd => sub {
480 my ($pl, $buf) = @_; 647 my ($pl, $buf) = @_;
481 648
482 my $msg = eval { from_json $buf }; 649 my $msg = eval { from_json $buf };
483 650
484 if (ref $msg) { 651 if (ref $msg) {
485 if (my $cb = $extcmd{$msg->{msgtype}}) { 652 if (my $cb = $extcmd{$msg->{msgtype}}) {
486 if (my %reply = $cb->[0]->($pl, $msg)) { 653 if (my %reply = $cb->[0]->($pl, $msg)) {
487 $pl->ext_reply ($msg->{msgid}, %reply); 654 $pl->ext_reply ($msg->{msgid}, %reply);
655 }
488 } 656 }
657 } else {
658 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
489 } 659 }
490 } else { 660
491 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 661 cf::override;
492 } 662 },
493 663;
494 1
495}
496 664
497############################################################################# 665#############################################################################
498# load/save/clean perl data associated with a map 666# load/save/clean perl data associated with a map
499 667
500*cf::mapsupport::on_clean = sub { 668*cf::mapsupport::on_clean = sub {
… …
502 670
503 my $path = $map->tmpname; 671 my $path = $map->tmpname;
504 defined $path or return; 672 defined $path or return;
505 673
506 unlink "$path.cfperl"; 674 unlink "$path.cfperl";
675 unlink "$path.pst";
507}; 676};
508 677
509*cf::mapsupport::on_swapin = 678*cf::mapsupport::on_swapin =
510*cf::mapsupport::on_load = sub { 679*cf::mapsupport::on_load = sub {
511 my ($map) = @_; 680 my ($map) = @_;
… …
522 or return; # too new 691 or return; # too new
523 692
524 $map->_set_obs ($data->{obs}); 693 $map->_set_obs ($data->{obs});
525}; 694};
526 695
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::; 696attach_to_maps prio => -10000, package => cf::mapsupport::;
555 697
556############################################################################# 698#############################################################################
557# load/save perl data associated with player->ob objects 699# load/save perl data associated with player->ob objects
558 700
… …
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

Diff Legend

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