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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines