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.42 by root, Fri Aug 25 15:31:44 2006 UTC vs.
Revision 1.53 by root, Tue Aug 29 13:11:58 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@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 73@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
77@safe::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
78 74
79# we bless all objects into (empty) derived classes to force a method lookup 75# we bless all objects into (empty) derived classes to force a method lookup
80# within the Safe compartment. 76# within the Safe compartment.
81for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) { 77for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) {
82 no strict 'refs'; 78 no strict 'refs';
83 @{"safe::$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 {
… …
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
112=item $object->detach ($attachment)
113
114Attach/detach a pre-registered attachment to an object.
115
116=item $player->attach ($attachment, key => $value...)
117
118=item $player->detach ($attachment)
119
120Attach/detach a pre-registered attachment to a player.
121
122=item $map->attach ($attachment, key => $value...)
123
124=item $map->detach ($attachment)
125
126Attach/detach a pre-registered attachment to a map.
100 127
101=item cf::attach_global ... 128=item cf::attach_global ...
102 129
103=item cf::attach_to_type ... 130Attach handlers for global events.
131
132This and all following C<attach_*>-functions expect any number of the
133following handler/hook descriptions:
134
135=over 4
136
137=item prio => $number
138
139Set the priority for all following handlers/hooks (unless overwritten
140by another C<prio> setting). Lower priority handlers get executed
141earlier. The default priority is C<0>, and many built-in handlers are
142registered at priority C<-1000>, so lower priorities should not be used
143unless you know what you are doing.
144
145=item on_I<event> => \&cb
146
147Call the given code reference whenever the named event happens (event is
148something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
149handlers are recognised generally depends on the type of object these
150handlers attach to).
151
152See F<include/eventinc.h> for the full list of events supported, and their
153class.
154
155=item package => package::
156
157Look for sub functions of the name C<< on_I<event> >> in the given
158package and register them. Only handlers for eevents supported by the
159object/class are recognised.
160
161=back
162
163=item cf::attach_to_type $object_type, $subtype, ...
164
165Attach handlers for a specific object type (e.g. TRANSPORT) and
166subtype. If C<$subtype> is zero or undef, matches all objects of the given
167type.
104 168
105=item cf::attach_to_objects ... 169=item cf::attach_to_objects ...
106 170
171Attach handlers to all objects. Do not use this except for debugging or
172very rare events, as handlers are (obviously) called for I<all> objects in
173the game.
174
107=item cf::attach_to_players ... 175=item cf::attach_to_players ...
108 176
177Attach handlers to all players.
178
109=item cf::attach_to_maps ... 179=item cf::attach_to_maps ...
110 180
111 prio => $number, # lower is earlier 181Attach handlers to all maps.
112 on_xxx => \&cb, 182
113 package => package::, 183=item cf:register_attachment $name, ...
184
185Register an attachment by name through which objects can refer to this
186attachment.
187
188=item cf:register_map_attachment $name, ...
189
190Register an attachment by name through which maps can refer to this
191attachment.
114 192
115=cut 193=cut
116 194
117# the following variables are defined in .xs and must not be re-created 195# the following variables are defined in .xs and must not be re-created
118our @CB_GLOBAL = (); # registry for all global events 196our @CB_GLOBAL = (); # registry for all global events
119our @CB_OBJECT = (); 197our @CB_OBJECT = (); # all objects (should not be used except in emergency)
120our @CB_PLAYER = (); 198our @CB_PLAYER = ();
121our @CB_TYPE = (); # registry for type (cf-object class) based events 199our @CB_TYPE = (); # registry for type (cf-object class) based events
122our @CB_MAP = (); 200our @CB_MAP = ();
123 201
202my %attachment;
203
124sub _attach_cb($\%$$$) { 204sub _attach_cb($\%$$$) {
125 my ($registry, $undo, $event, $prio, $cb) = @_; 205 my ($registry, $undo, $event, $prio, $cb) = @_;
126 206
127 use sort 'stable'; 207 use sort 'stable';
128 208
… …
136} 216}
137 217
138# attach handles attaching event callbacks 218# attach handles attaching event callbacks
139# the only thing the caller has to do is pass the correct 219# the only thing the caller has to do is pass the correct
140# registry (== where the callback attaches to). 220# registry (== where the callback attaches to).
141sub _attach(\@$\@) { 221sub _attach(\@$@) {
142 my ($registry, $klass, $arg) = @_; 222 my ($registry, $klass, @arg) = @_;
143 223
144 my $prio = 0; 224 my $prio = 0;
145 225
146 my %undo = ( 226 my %undo = (
147 registry => $registry, 227 registry => $registry,
148 cb => [], 228 cb => [],
149 ); 229 );
150 230
151 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; 231 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
152 232
153 while (@$arg) { 233 while (@arg) {
154 my $type = shift @$arg; 234 my $type = shift @arg;
155 235
156 if ($type eq "prio") { 236 if ($type eq "prio") {
157 $prio = shift @$arg; 237 $prio = shift @arg;
158 238
159 } elsif ($type eq "package") { 239 } elsif ($type eq "package") {
160 my $pkg = shift @$arg; 240 my $pkg = shift @arg;
161 241
162 while (my ($name, $id) = each %cb_id) { 242 while (my ($name, $id) = each %cb_id) {
163 if (my $cb = $pkg->can ($name)) { 243 if (my $cb = $pkg->can ($name)) {
164 _attach_cb $registry, %undo, $id, $prio, $cb; 244 _attach_cb $registry, %undo, $id, $prio, $cb;
165 } 245 }
166 } 246 }
167 247
168 } elsif (exists $cb_id{$type}) { 248 } elsif (exists $cb_id{$type}) {
169 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @$arg; 249 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg;
170 250
171 } elsif (ref $type) { 251 } elsif (ref $type) {
172 warn "attaching objects not supported, ignoring.\n"; 252 warn "attaching objects not supported, ignoring.\n";
173 253
174 } else { 254 } else {
175 shift @$arg; 255 shift @arg;
176 warn "attach argument '$type' not supported, ignoring.\n"; 256 warn "attach argument '$type' not supported, ignoring.\n";
177 } 257 }
178 } 258 }
179 259
180 \%undo 260 \%undo
181} 261}
182 262
263sub _attach_attachment {
264 my ($obj, $name, %arg) = @_;
265
266 my $res;
267
268 if (my $attach = $attachment{$name}) {
269 my $registry = $obj->registry;
270
271 for (@$attach) {
272 my ($klass, @attach) = @$_;
273 $res = _attach @$registry, $klass, @attach;
274 }
275
276 $obj->{$name} = \%arg;
277 } else {
278 warn "object uses attachment '$name' that is not available, postponing.\n";
279 }
280
281 $obj->{_attachment}{$name} = undef;
282
283 $res->{attachment} = $name;
284 $res
285}
286
183sub cf::object::attach { 287sub cf::object::attach {
288 my ($obj, $name, %arg) = @_;
289
290 _attach_attachment $obj, $name, %arg;
291}
292
293sub cf::player::attach {
294 my ($obj, $name, %arg) = @_;
295
296 _attach_attachment $obj, $name, %arg;
297}
298
299sub cf::map::attach {
300 my ($obj, $name, %arg) = @_;
301
302 _attach_attachment $obj, $name, %arg;
303}
304
305sub cf::object::detach {
306 my ($obj, $name) = @_;
184 die; 307 die;#d#
308}
309sub cf::player::detach {
310 my ($obj, $name) = @_;
311 die;#d#
312}
313sub cf::map::detach {
314 my ($obj, $name) = @_;
315 die;#d#
185} 316}
186 317
187sub attach_global { 318sub attach_global {
188 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 319 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
189} 320}
190 321
191sub attach_to_type { 322sub attach_to_type {
192 my $type = shift; 323 my $type = shift;
324 my $subtype = shift;
325
193 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_ 326 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
194} 327}
195 328
196sub attach_to_objects { 329sub attach_to_objects {
197 _attach @CB_OBJECT, KLASS_OBJECT, @_ 330 _attach @CB_OBJECT, KLASS_OBJECT, @_
198} 331}
… …
203 336
204sub attach_to_maps { 337sub attach_to_maps {
205 _attach @CB_MAP, KLASS_MAP, @_ 338 _attach @CB_MAP, KLASS_MAP, @_
206} 339}
207 340
341sub register_attachment {
342 my $name = shift;
343
344 $attachment{$name} = [[KLASS_OBJECT, @_]];
345}
346
347sub register_map_attachment {
348 my $name = shift;
349
350 $attachment{$name} = [[KLASS_MAP, @_]];
351}
352
208our $override; 353our $override;
354our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
209 355
210sub override() { 356sub override {
211 $override = 1 357 $override = 1;
358 @invoke_results = ();
212} 359}
213 360
214sub invoke { 361sub do_invoke {
215 my $event = shift; 362 my $event = shift;
216 my $callbacks = shift; 363 my $callbacks = shift;
364
365 @invoke_results = ();
217 366
218 local $override; 367 local $override;
219 368
220 for (@$callbacks) { 369 for (@$callbacks) {
221 eval { &{$_->[1]} }; 370 eval { &{$_->[1]} };
… …
231 380
232 0 381 0
233} 382}
234 383
235############################################################################# 384#############################################################################
385# object support
386
387sub instantiate {
388 my ($obj, $data) = @_;
389
390 $data = from_json $data;
391
392 for (@$data) {
393 my ($name, $args) = @$_;
394
395 $obj->attach ($name, %{$args || {} });
396 }
397}
398
399# basically do the same as instantiate, without calling instantiate
400sub reattach {
401 my ($obj) = @_;
402 my $registry = $obj->registry;
403
404 @$registry = ();
405
406 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
407
408 for my $name (keys %{ $obj->{_attachment} || {} }) {
409 if (my $attach = $attachment{$name}) {
410 for (@$attach) {
411 my ($klass, @attach) = @$_;
412 _attach @$registry, $klass, @attach;
413 }
414 } else {
415 warn "object uses attachment '$name' that is not available, postponing.\n";
416 }
417 }
418}
419
420sub object_freezer_save {
421 my ($filename, $objs) = @_;
422
423 if (@$objs) {
424 open my $fh, ">:raw", "$filename.pst~";
425 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
426 close $fh;
427 chmod SAVE_MODE, "$filename.pst~";
428 rename "$filename.pst~", "$filename.pst";
429 } else {
430 unlink "$filename.pst";
431 }
432
433 chmod SAVE_MODE, "$filename~";
434 rename "$filename~", $filename;
435}
436
437sub object_thawer_load {
438 my ($filename) = @_;
439
440 open my $fh, "<:raw:perlio", "$filename.pst"
441 or return;
442
443 eval { local $/; (Storable::thaw <$fh>)->{objs} }
444}
445
446attach_to_objects
447 prio => -1000000,
448 on_clone => sub {
449 my ($src, $dst) = @_;
450
451 @{$dst->registry} = @{$src->registry};
452
453 %$dst = %$src;
454
455 %{$dst->{_attachment}} = %{$src->{_attachment}}
456 if exists $src->{_attachment};
457 },
458;
459
460#############################################################################
236# old plug-in events 461# old plug-in events
237 462
238sub inject_event { 463sub inject_event {
239 my $extension = shift; 464 my $extension = shift;
240 my $event_code = shift; 465 my $event_code = shift;
… …
284} 509}
285 510
286sub register { 511sub register {
287 my ($base, $pkg) = @_; 512 my ($base, $pkg) = @_;
288 513
289 for my $idx (0 .. $#PLUGIN_EVENT) { 514 #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} 515}
296 516
297sub load_extension { 517sub load_extension {
298 my ($path) = @_; 518 my ($path) = @_;
299 519
… …
330 my ($pkg) = @_; 550 my ($pkg) = @_;
331 551
332 warn "removing extension $pkg\n"; 552 warn "removing extension $pkg\n";
333 553
334 # remove hooks 554 # remove hooks
555 #TODO
335 for my $idx (0 .. $#PLUGIN_EVENT) { 556# for my $idx (0 .. $#PLUGIN_EVENT) {
336 delete $hook[$idx]{$pkg}; 557# delete $hook[$idx]{$pkg};
337 } 558# }
338 559
339 # remove commands 560 # remove commands
340 for my $name (keys %command) { 561 for my $name (keys %command) {
341 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 562 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
342 563
… …
352 # remove extcmds 573 # remove extcmds
353 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 574 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
354 delete $extcmd{$name}; 575 delete $extcmd{$name};
355 } 576 }
356 577
357 if (my $cb = $pkg->can ("on_unload")) { 578 if (my $cb = $pkg->can ("unload")) {
358 eval { 579 eval {
359 $cb->($pkg); 580 $cb->($pkg);
360 1 581 1
361 } or warn "$pkg unloaded, but with errors: $@"; 582 } or warn "$pkg unloaded, but with errors: $@";
362 } 583 }
… …
408 Symbol::delete_package $k; 629 Symbol::delete_package $k;
409 } 630 }
410 631
411 # 4. get rid of safe::, as good as possible 632 # 4. get rid of safe::, as good as possible
412 Symbol::delete_package "safe::$_" 633 Symbol::delete_package "safe::$_"
413 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region); 634 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
414 635
415 # 5. remove register_script_function callbacks 636 # 5. remove register_script_function callbacks
416 # TODO 637 # TODO
417 638
418 # 6. unload cf.pm "a bit" 639 # 6. unload cf.pm "a bit"
… …
448 }; 669 };
449 } 670 }
450}; 671};
451 672
452############################################################################# 673#############################################################################
453# utility functions
454
455use JSON::Syck (); # TODO# replace by JSON::PC once working
456
457sub from_json($) {
458 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
459 JSON::Syck::Load $_[0]
460}
461
462sub to_json($) {
463 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
464 JSON::Syck::Dump $_[0]
465}
466
467#############################################################################
468# extcmd framework, basically convert ext <msg> 674# extcmd framework, basically convert ext <msg>
469# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 675# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
470 676
471sub on_extcmd { 677attach_to_players
678 on_extcmd => sub {
472 my ($pl, $buf) = @_; 679 my ($pl, $buf) = @_;
473 680
474 my $msg = eval { from_json $buf }; 681 my $msg = eval { from_json $buf };
475 682
476 if (ref $msg) { 683 if (ref $msg) {
477 if (my $cb = $extcmd{$msg->{msgtype}}) { 684 if (my $cb = $extcmd{$msg->{msgtype}}) {
478 if (my %reply = $cb->[0]->($pl, $msg)) { 685 if (my %reply = $cb->[0]->($pl, $msg)) {
479 $pl->ext_reply ($msg->{msgid}, %reply); 686 $pl->ext_reply ($msg->{msgid}, %reply);
687 }
480 } 688 }
689 } else {
690 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
481 } 691 }
482 } else { 692
483 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 693 cf::override;
484 } 694 },
485 695;
486 1
487}
488 696
489############################################################################# 697#############################################################################
490# load/save/clean perl data associated with a map 698# load/save/clean perl data associated with a map
491 699
492*cf::mapsupport::on_clean = sub { 700*cf::mapsupport::on_clean = sub {
493 my ($map) = @_; 701 my ($map) = @_;
494 702
495 my $path = $map->tmpname; 703 my $path = $map->tmpname;
496 defined $path or return; 704 defined $path or return;
497 705
498 unlink "$path.cfperl"; 706 unlink "$path.pst";
499}; 707};
500 708
709# old style persistent data, TODO: remove #d#
501*cf::mapsupport::on_swapin = 710*cf::mapsupport::on_swapin =
502*cf::mapsupport::on_load = sub { 711*cf::mapsupport::on_load = sub {
503 my ($map) = @_; 712 my ($map) = @_;
504 713
505 my $path = $map->tmpname; 714 my $path = $map->tmpname;
… …
512 721
513 $data->{version} <= 1 722 $data->{version} <= 1
514 or return; # too new 723 or return; # too new
515 724
516 $map->_set_obs ($data->{obs}); 725 $map->_set_obs ($data->{obs});
517}; 726 $map->invoke (EVENT_MAP_UPGRADE);
518
519*cf::mapsupport::on_swapout = sub {
520 my ($map) = @_;
521
522 my $path = $map->tmpname;
523 $path = $map->path unless defined $path;
524
525 my $obs = $map->_get_obs;
526
527 if (defined $obs) {
528 open my $fh, ">:raw", "$path.cfperl"
529 or die "$path.cfperl: $!";
530
531 stat $path;
532
533 print $fh Storable::nfreeze {
534 size => (stat _)[7],
535 time => (stat _)[9],
536 version => 1,
537 obs => $obs,
538 };
539
540 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
541 } else {
542 unlink "$path.cfperl";
543 }
544}; 727};
545 728
546attach_to_maps prio => -10000, package => cf::mapsupport::; 729attach_to_maps prio => -10000, package => cf::mapsupport::;
547 730
548############################################################################# 731#############################################################################
… …
561 $o->set_ob_key_value ("_perl_data"); 744 $o->set_ob_key_value ("_perl_data");
562 745
563 %$o = %{ Storable::thaw pack "H*", $value }; 746 %$o = %{ Storable::thaw pack "H*", $value };
564 } 747 }
565 } 748 }
566 },
567 on_save => sub {
568 my ($pl, $path) = @_;
569
570 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
571 for grep %$_, all_objects $pl->ob;
572 }, 749 },
573; 750;
574 751
575############################################################################# 752#############################################################################
576# core extensions - in perl 753# core extensions - in perl
… …
715 $TICK_WATCHER->at ($NEXT_TICK); 892 $TICK_WATCHER->at ($NEXT_TICK);
716 $TICK_WATCHER->start; 893 $TICK_WATCHER->start;
717 }, 894 },
718); 895);
719 896
897_reload_2;
898
7201 8991
721 900

Diff Legend

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