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.11 by root, Sun Mar 26 15:52:03 2006 UTC vs.
Revision 1.52 by root, Mon Aug 28 16:52:51 2006 UTC

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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines