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.40 by root, Fri Aug 25 15:21:57 2006 UTC vs.
Revision 1.48 by root, Sun Aug 27 15:24:22 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, key => $value...)
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.
100 121
101=item cf::attach_global ... 122=item cf::attach_global ...
102 123
103=item cf::attach_to_type ... 124Attach handlers for global events.
125
126This and all following C<attach_*>-functions expect any number of the
127following handler/hook descriptions:
128
129=over 4
130
131=item prio => $number
132
133Set the priority for all following handlers/hooks (unless overwritten
134by another C<prio> setting). Lower priority handlers get executed
135earlier. The default priority is C<0>, and many built-in handlers are
136registered at priority C<-1000>, so lower priorities should not be used
137unless you know what you are doing.
138
139=item on_I<event> => \&cb
140
141Call the given code reference whenever the named event happens (event is
142something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
143handlers are recognised generally depends on the type of object these
144handlers attach to).
145
146See F<include/eventinc.h> for the full list of events supported, and their
147class.
148
149=item package => package::
150
151Look for sub functions of the name C<< on_I<event> >> in the given
152package and register them. Only handlers for eevents supported by the
153object/class are recognised.
154
155=back
156
157=item cf::attach_to_type $object_type, $subtype, ...
158
159Attach handlers for a specific object type (e.g. TRANSPORT) and
160subtype. If C<$subtype> is zero or undef, matches all objects of the given
161type.
104 162
105=item cf::attach_to_objects ... 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 ... 169=item cf::attach_to_players ...
108 170
171Attach handlers to all players.
172
109=item cf::attach_to_maps ... 173=item cf::attach_to_maps ...
110 174
111 prio => $number, # lower 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
117# the following variables are defined in .xs and must not be re-created 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
119our @CB_OBJECT = (); 183our @CB_OBJECT = (); # all objects (should not be used except in emergency)
120our @CB_PLAYER = (); 184our @CB_PLAYER = ();
121our @CB_TYPE = (); # registry for type (cf-object class) based events 185our @CB_TYPE = (); # registry for type (cf-object class) based events
122our @CB_MAP = (); 186our @CB_MAP = ();
123 187
188my %attachment;
189
124sub _attach_cb($\%$$$) { 190sub _attach_cb($\%$$$) {
125 my ($registry, $undo, $event, $prio, $cb) = @_; 191 my ($registry, $undo, $event, $prio, $cb) = @_;
126 192
127 use sort 'stable'; 193 use sort 'stable';
128 194
… …
136} 202}
137 203
138# attach handles attaching event callbacks 204# attach handles attaching event callbacks
139# 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
140# registry (== where the callback attaches to). 206# registry (== where the callback attaches to).
141sub _attach(\@$\@) { 207sub _attach(\@$@) {
142 my ($registry, $klass, $arg) = @_; 208 my ($registry, $klass, @arg) = @_;
143 209
144 my $prio = 0; 210 my $prio = 0;
145 211
146 my %undo = ( 212 my %undo = (
147 registry => $registry, 213 registry => $registry,
148 cb => [], 214 cb => [],
149 ); 215 );
150 216
151 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;
152 218
153 while (@$arg) { 219 while (@arg) {
154 my $type = shift @$arg; 220 my $type = shift @arg;
155 221
156 if ($type eq "prio") { 222 if ($type eq "prio") {
157 $prio = shift @$arg; 223 $prio = shift @arg;
158 224
159 } elsif ($type eq "package") { 225 } elsif ($type eq "package") {
160 my $pkg = shift @$arg; 226 my $pkg = shift @arg;
161 227
162 while (my ($name, $id) = each %cb_id) { 228 while (my ($name, $id) = each %cb_id) {
163 if (my $cb = $pkg->can ($name)) { 229 if (my $cb = $pkg->can ($name)) {
164 _attach_cb $registry, %undo, $id, $prio, $cb; 230 _attach_cb $registry, %undo, $id, $prio, $cb;
165 } 231 }
166 } 232 }
167 233
168 } elsif (exists $cb_id{$type}) { 234 } elsif (exists $cb_id{$type}) {
169 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @$arg; 235 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg;
170 236
171 } elsif (ref $type) { 237 } elsif (ref $type) {
172 warn "attaching objects not supported, ignoring.\n"; 238 warn "attaching objects not supported, ignoring.\n";
173 239
174 } else { 240 } else {
175 shift @$arg; 241 shift @arg;
176 warn "attach argument '$type' not supported, ignoring.\n"; 242 warn "attach argument '$type' not supported, ignoring.\n";
177 } 243 }
178 } 244 }
179 245
180 \%undo 246 \%undo
181} 247}
182 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 push @{$obj->{_attachment}}, $name;
268
269 $res->{attachment} = $name;
270 $res
271}
272
183sub cf::object::attach { 273sub cf::object::attach {
184 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;
185} 289}
186 290
187sub attach_global { 291sub attach_global {
188 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 292 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
189} 293}
190 294
191sub attach_to_type { 295sub attach_to_type {
192 my $type = shift; 296 my $type = shift;
297 my $subtype = shift;
298
193 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_ 299 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
194} 300}
195 301
196sub attach_to_objects { 302sub attach_to_objects {
197 _attach @CB_OBJECT, KLASS_OBJECT, @_ 303 _attach @CB_OBJECT, KLASS_OBJECT, @_
198} 304}
… …
203 309
204sub attach_to_maps { 310sub attach_to_maps {
205 _attach @CB_MAP, KLASS_MAP, @_ 311 _attach @CB_MAP, KLASS_MAP, @_
206} 312}
207 313
314sub register_attachment {
315 my $name = shift;
316
317 $attachment{$name} = [[KLASS_OBJECT, @_]];
318}
319
208our $override; 320our $override;
321our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
209 322
210sub override() { 323sub override {
211 $override = 1 324 $override = 1;
325 @invoke_results = ();
212} 326}
213 327
214sub invoke { 328sub do_invoke {
215 my $event = shift; 329 my $event = shift;
216 my $callbacks = shift; 330 my $callbacks = shift;
331
332 @invoke_results = ();
217 333
218 local $override; 334 local $override;
219 335
220 for (@$callbacks) { 336 for (@$callbacks) {
221 eval { &{$_->[1]} }; 337 eval { &{$_->[1]} };
… …
231 347
232 0 348 0
233} 349}
234 350
235############################################################################# 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 my ($obj) = @_;
368 my $registry = $obj->registry;
369
370 @$registry = ();
371
372 for my $name (@{ $obj->{_attachment} }) {
373 if (my $attach = $attachment{$name}) {
374 for (@$attach) {
375 my ($klass, @attach) = @$_;
376 _attach @$registry, $klass, @attach;
377 }
378 } else {
379 warn "object uses attachment '$name' that is not available, postponing.\n";
380 }
381 }
382}
383
384sub object_freezer_save {
385 my ($filename, $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 open my $fh, "<:raw:perlio", "$filename.pst"
404 or return;
405
406 eval { local $/; (Storable::thaw <$fh>)->{objs} }
407}
408
409attach_to_objects
410 prio => -1000000,
411 on_clone => sub {
412 my ($src, $dst) = @_;
413
414 @{$dst->registry} = @{$src->registry};
415
416 %$dst = %$src;
417
418 $dst->{_attachment} = [@{ $src->{_attachment} }]
419 if exists $src->{_attachment};
420 },
421;
422
423#############################################################################
236# old plug-in events 424# old plug-in events
237 425
238sub inject_event { 426sub inject_event {
239 my $extension = shift; 427 my $extension = shift;
240 my $event_code = shift; 428 my $event_code = shift;
… …
284} 472}
285 473
286sub register { 474sub register {
287 my ($base, $pkg) = @_; 475 my ($base, $pkg) = @_;
288 476
289 for my $idx (0 .. $#PLUGIN_EVENT) { 477 #TODO
290 if (my $ref = $pkg->can ("on_$PLUGIN_EVENT[$idx]")) {
291 #warn "registering $PLUGIN_EVENT[$idx] hook to '$pkg'\n";
292 $hook[$idx]{$base} = $ref;
293 }
294 }
295} 478}
296 479
297sub load_extension { 480sub load_extension {
298 my ($path) = @_; 481 my ($path) = @_;
299 482
300 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 483 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
301 my $base = $1; 484 my $base = $1;
302 my $pkg = $1; 485 my $pkg = $1;
303 $pkg =~ s/[^[:word:]]/_/g; 486 $pkg =~ s/[^[:word:]]/_/g;
304 $pkg = "cf::ext::$pkg"; 487 $pkg = "ext::$pkg";
305 488
306 warn "loading '$path' into '$pkg'\n"; 489 warn "loading '$path' into '$pkg'\n";
307 490
308 open my $fh, "<:utf8", $path 491 open my $fh, "<:utf8", $path
309 or die "$path: $!"; 492 or die "$path: $!";
… …
330 my ($pkg) = @_; 513 my ($pkg) = @_;
331 514
332 warn "removing extension $pkg\n"; 515 warn "removing extension $pkg\n";
333 516
334 # remove hooks 517 # remove hooks
518 #TODO
335 for my $idx (0 .. $#PLUGIN_EVENT) { 519# for my $idx (0 .. $#PLUGIN_EVENT) {
336 delete $hook[$idx]{$pkg}; 520# delete $hook[$idx]{$pkg};
337 } 521# }
338 522
339 # remove commands 523 # remove commands
340 for my $name (keys %command) { 524 for my $name (keys %command) {
341 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 525 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
342 526
… …
352 # remove extcmds 536 # remove extcmds
353 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 537 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
354 delete $extcmd{$name}; 538 delete $extcmd{$name};
355 } 539 }
356 540
357 if (my $cb = $pkg->can ("on_unload")) { 541 if (my $cb = $pkg->can ("unload")) {
358 eval { 542 eval {
359 $cb->($pkg); 543 $cb->($pkg);
360 1 544 1
361 } or warn "$pkg unloaded, but with errors: $@"; 545 } or warn "$pkg unloaded, but with errors: $@";
362 } 546 }
… …
406 } 590 }
407 591
408 Symbol::delete_package $k; 592 Symbol::delete_package $k;
409 } 593 }
410 594
411 # 4. get rid of ext::, as good as possible 595 # 4. get rid of safe::, as good as possible
412 Symbol::delete_package "ext::$_" 596 Symbol::delete_package "safe::$_"
413 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region); 597 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
414 598
415 # 5. remove register_script_function callbacks 599 # 5. remove register_script_function callbacks
416 # TODO 600 # TODO
417 601
418 # 6. unload cf.pm "a bit" 602 # 6. unload cf.pm "a bit"
419 delete $INC{"cf.pm"}; 603 delete $INC{"cf.pm"};
420 604
421 # don't, removes xs symbols, too 605 # don't, removes xs symbols, too,
606 # and global variables created in xs
422 #Symbol::delete_package __PACKAGE__; 607 #Symbol::delete_package __PACKAGE__;
423 608
424 # 7. reload cf.pm 609 # 7. reload cf.pm
425 $msg->("reloading cf.pm"); 610 $msg->("reloading cf.pm");
426 require cf; 611 require cf;
… …
447 }; 632 };
448 } 633 }
449}; 634};
450 635
451############################################################################# 636#############################################################################
452# utility functions
453
454use JSON::Syck (); # TODO# replace by JSON::PC once working
455
456sub from_json($) {
457 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
458 JSON::Syck::Load $_[0]
459}
460
461sub to_json($) {
462 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
463 JSON::Syck::Dump $_[0]
464}
465
466#############################################################################
467# extcmd framework, basically convert ext <msg> 637# extcmd framework, basically convert ext <msg>
468# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 638# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
469 639
470sub on_extcmd { 640attach_to_players
641 on_extcmd => sub {
471 my ($pl, $buf) = @_; 642 my ($pl, $buf) = @_;
472 643
473 my $msg = eval { from_json $buf }; 644 my $msg = eval { from_json $buf };
474 645
475 if (ref $msg) { 646 if (ref $msg) {
476 if (my $cb = $extcmd{$msg->{msgtype}}) { 647 if (my $cb = $extcmd{$msg->{msgtype}}) {
477 if (my %reply = $cb->[0]->($pl, $msg)) { 648 if (my %reply = $cb->[0]->($pl, $msg)) {
478 $pl->ext_reply ($msg->{msgid}, %reply); 649 $pl->ext_reply ($msg->{msgid}, %reply);
650 }
479 } 651 }
652 } else {
653 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
480 } 654 }
481 } else { 655
482 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 656 cf::override;
483 } 657 },
484 658;
485 1
486}
487 659
488############################################################################# 660#############################################################################
489# load/save/clean perl data associated with a map 661# load/save/clean perl data associated with a map
490 662
491*cf::mapsupport::on_clean = sub { 663*cf::mapsupport::on_clean = sub {
… …
493 665
494 my $path = $map->tmpname; 666 my $path = $map->tmpname;
495 defined $path or return; 667 defined $path or return;
496 668
497 unlink "$path.cfperl"; 669 unlink "$path.cfperl";
670 unlink "$path.pst";
498}; 671};
499 672
500*cf::mapsupport::on_swapin = 673*cf::mapsupport::on_swapin =
501*cf::mapsupport::on_load = sub { 674*cf::mapsupport::on_load = sub {
502 my ($map) = @_; 675 my ($map) = @_;
… …
513 or return; # too new 686 or return; # too new
514 687
515 $map->_set_obs ($data->{obs}); 688 $map->_set_obs ($data->{obs});
516}; 689};
517 690
518*cf::mapsupport::on_swapout = sub {
519 my ($map) = @_;
520
521 my $path = $map->tmpname;
522 $path = $map->path unless defined $path;
523
524 my $obs = $map->_get_obs;
525
526 if (defined $obs) {
527 open my $fh, ">:raw", "$path.cfperl"
528 or die "$path.cfperl: $!";
529
530 stat $path;
531
532 print $fh Storable::nfreeze {
533 size => (stat _)[7],
534 time => (stat _)[9],
535 version => 1,
536 obs => $obs,
537 };
538
539 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
540 } else {
541 unlink "$path.cfperl";
542 }
543};
544
545attach_to_maps prio => -10000, package => cf::mapsupport::; 691attach_to_maps prio => -10000, package => cf::mapsupport::;
546 692
547############################################################################# 693#############################################################################
548# load/save perl data associated with player->ob objects 694# load/save perl data associated with player->ob objects
549 695
… …
560 $o->set_ob_key_value ("_perl_data"); 706 $o->set_ob_key_value ("_perl_data");
561 707
562 %$o = %{ Storable::thaw pack "H*", $value }; 708 %$o = %{ Storable::thaw pack "H*", $value };
563 } 709 }
564 } 710 }
565 },
566 on_save => sub {
567 my ($pl, $path) = @_;
568
569 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
570 for grep %$_, all_objects $pl->ob;
571 }, 711 },
572; 712;
573 713
574############################################################################# 714#############################################################################
575# core extensions - in perl 715# core extensions - in perl
… …
623} 763}
624 764
625############################################################################# 765#############################################################################
626# map scripting support 766# map scripting support
627 767
628our $safe = new Safe "ext"; 768our $safe = new Safe "safe";
629our $safe_hole = new Safe::Hole; 769our $safe_hole = new Safe::Hole;
630 770
631$SIG{FPE} = 'IGNORE'; 771$SIG{FPE} = 'IGNORE';
632 772
633$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 773$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
… …
639 ["cf::object::player" => qw(player)], 779 ["cf::object::player" => qw(player)],
640 ["cf::player" => qw(peaceful)], 780 ["cf::player" => qw(peaceful)],
641) { 781) {
642 no strict 'refs'; 782 no strict 'refs';
643 my ($pkg, @funs) = @$_; 783 my ($pkg, @funs) = @$_;
644 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 784 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
645 for @funs; 785 for @funs;
646} 786}
647 787
648sub safe_eval($;@) { 788sub safe_eval($;@) {
649 my ($code, %vars) = @_; 789 my ($code, %vars) = @_;
… …
651 my $qcode = $code; 791 my $qcode = $code;
652 $qcode =~ s/"/‟/g; # not allowed in #line filenames 792 $qcode =~ s/"/‟/g; # not allowed in #line filenames
653 $qcode =~ s/\n/\\n/g; 793 $qcode =~ s/\n/\\n/g;
654 794
655 local $_; 795 local $_;
656 local @ext::cf::_safe_eval_args = values %vars; 796 local @safe::cf::_safe_eval_args = values %vars;
657 797
658 $code = 798 my $eval =
659 "do {\n" 799 "do {\n"
660 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 800 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
661 . "#line 0 \"{$qcode}\"\n" 801 . "#line 0 \"{$qcode}\"\n"
662 . $code 802 . $code
663 . "\n}" 803 . "\n}"
664 ; 804 ;
665 805
666 sub_generation_inc; 806 sub_generation_inc;
667 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 807 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
668 sub_generation_inc; 808 sub_generation_inc;
809
810 if ($@) {
811 warn "$@";
812 warn "while executing safe code '$code'\n";
813 warn "with arguments " . (join " ", %vars) . "\n";
814 }
669 815
670 wantarray ? @res : $res[0] 816 wantarray ? @res : $res[0]
671} 817}
672 818
673sub register_script_function { 819sub register_script_function {
674 my ($fun, $cb) = @_; 820 my ($fun, $cb) = @_;
675 821
676 no strict 'refs'; 822 no strict 'refs';
677 *{"ext::$fun"} = $safe_hole->wrap ($cb); 823 *{"safe::$fun"} = $safe_hole->wrap ($cb);
678} 824}
679 825
680############################################################################# 826#############################################################################
681# the server's main() 827# the server's main()
682 828
… …
708 $TICK_WATCHER->at ($NEXT_TICK); 854 $TICK_WATCHER->at ($NEXT_TICK);
709 $TICK_WATCHER->start; 855 $TICK_WATCHER->start;
710 }, 856 },
711); 857);
712 858
859_reload_2;
860
7131 8611
714 862

Diff Legend

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