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.43 by root, Fri Aug 25 17:11:53 2006 UTC vs.
Revision 1.56 by root, Wed Aug 30 08:28:33 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=head3 EVENTS AND OBJECT ATTACHMENTS
111
112=over 4
113
114=item $object->attach ($attachment, key => $value...)
115
116=item $object->detach ($attachment)
117
118Attach/detach a pre-registered attachment to an object.
119
120=item $player->attach ($attachment, key => $value...)
121
122=item $player->detach ($attachment)
123
124Attach/detach a pre-registered attachment to a player.
125
126=item $map->attach ($attachment, key => $value...)
127
128=item $map->detach ($attachment)
129
130Attach/detach a pre-registered attachment to a map.
131
132=item $bool = $object->attached ($name)
133
134=item $bool = $player->attached ($name)
135
136=item $bool = $map->attached ($name)
137
138Checks wether the named attachment is currently attached to the object.
100 139
101=item cf::attach_global ... 140=item cf::attach_global ...
102 141
103=item cf::attach_to_type ... 142Attach handlers for global events.
143
144This and all following C<attach_*>-functions expect any number of the
145following handler/hook descriptions:
146
147=over 4
148
149=item prio => $number
150
151Set the priority for all following handlers/hooks (unless overwritten
152by another C<prio> setting). Lower priority handlers get executed
153earlier. The default priority is C<0>, and many built-in handlers are
154registered at priority C<-1000>, so lower priorities should not be used
155unless you know what you are doing.
156
157=item on_I<event> => \&cb
158
159Call the given code reference whenever the named event happens (event is
160something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
161handlers are recognised generally depends on the type of object these
162handlers attach to).
163
164See F<include/eventinc.h> for the full list of events supported, and their
165class.
166
167=item package => package::
168
169Look for sub functions of the name C<< on_I<event> >> in the given
170package and register them. Only handlers for eevents supported by the
171object/class are recognised.
172
173=back
174
175=item cf::attach_to_type $object_type, $subtype, ...
176
177Attach handlers for a specific object type (e.g. TRANSPORT) and
178subtype. If C<$subtype> is zero or undef, matches all objects of the given
179type.
104 180
105=item cf::attach_to_objects ... 181=item cf::attach_to_objects ...
106 182
183Attach handlers to all objects. Do not use this except for debugging or
184very rare events, as handlers are (obviously) called for I<all> objects in
185the game.
186
107=item cf::attach_to_players ... 187=item cf::attach_to_players ...
108 188
189Attach handlers to all players.
190
109=item cf::attach_to_maps ... 191=item cf::attach_to_maps ...
110 192
111 prio => $number, # lower is earlier 193Attach handlers to all maps.
112 on_xxx => \&cb, 194
113 package => package::, 195=item cf:register_attachment $name, ...
196
197Register an attachment by name through which objects can refer to this
198attachment.
199
200=item cf:register_player_attachment $name, ...
201
202Register an attachment by name through which players can refer to this
203attachment.
204
205=item cf:register_map_attachment $name, ...
206
207Register an attachment by name through which maps can refer to this
208attachment.
114 209
115=cut 210=cut
116 211
117# the following variables are defined in .xs and must not be re-created 212# the following variables are defined in .xs and must not be re-created
118our @CB_GLOBAL = (); # registry for all global events 213our @CB_GLOBAL = (); # registry for all global events
119our @CB_OBJECT = (); 214our @CB_OBJECT = (); # all objects (should not be used except in emergency)
120our @CB_PLAYER = (); 215our @CB_PLAYER = ();
121our @CB_TYPE = (); # registry for type (cf-object class) based events 216our @CB_TYPE = (); # registry for type (cf-object class) based events
122our @CB_MAP = (); 217our @CB_MAP = ();
123 218
219my %attachment;
220
124sub _attach_cb($\%$$$) { 221sub _attach_cb($\%$$$) {
125 my ($registry, $undo, $event, $prio, $cb) = @_; 222 my ($registry, $undo, $event, $prio, $cb) = @_;
126 223
127 use sort 'stable'; 224 use sort 'stable';
128 225
136} 233}
137 234
138# attach handles attaching event callbacks 235# attach handles attaching event callbacks
139# the only thing the caller has to do is pass the correct 236# the only thing the caller has to do is pass the correct
140# registry (== where the callback attaches to). 237# registry (== where the callback attaches to).
141sub _attach(\@$\@) { 238sub _attach(\@$@) {
142 my ($registry, $klass, $arg) = @_; 239 my ($registry, $klass, @arg) = @_;
143 240
144 my $prio = 0; 241 my $prio = 0;
145 242
146 my %undo = ( 243 my %undo = (
147 registry => $registry, 244 registry => $registry,
148 cb => [], 245 cb => [],
149 ); 246 );
150 247
151 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; 248 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
152 249
153 while (@$arg) { 250 while (@arg) {
154 my $type = shift @$arg; 251 my $type = shift @arg;
155 252
156 if ($type eq "prio") { 253 if ($type eq "prio") {
157 $prio = shift @$arg; 254 $prio = shift @arg;
158 255
159 } elsif ($type eq "package") { 256 } elsif ($type eq "package") {
160 my $pkg = shift @$arg; 257 my $pkg = shift @arg;
161 258
162 while (my ($name, $id) = each %cb_id) { 259 while (my ($name, $id) = each %cb_id) {
163 if (my $cb = $pkg->can ($name)) { 260 if (my $cb = $pkg->can ($name)) {
164 _attach_cb $registry, %undo, $id, $prio, $cb; 261 _attach_cb $registry, %undo, $id, $prio, $cb;
165 } 262 }
166 } 263 }
167 264
168 } elsif (exists $cb_id{$type}) { 265 } elsif (exists $cb_id{$type}) {
169 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @$arg; 266 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg;
170 267
171 } elsif (ref $type) { 268 } elsif (ref $type) {
172 warn "attaching objects not supported, ignoring.\n"; 269 warn "attaching objects not supported, ignoring.\n";
173 270
174 } else { 271 } else {
175 shift @$arg; 272 shift @arg;
176 warn "attach argument '$type' not supported, ignoring.\n"; 273 warn "attach argument '$type' not supported, ignoring.\n";
177 } 274 }
178 } 275 }
179 276
180 \%undo 277 \%undo
181} 278}
182 279
280sub _attach_attachment {
281 my ($obj, $name, %arg) = @_;
282
283 return if exists $obj->{_attachment}{$name};
284
285 my $res;
286
287 if (my $attach = $attachment{$name}) {
288 my $registry = $obj->registry;
289
290 for (@$attach) {
291 my ($klass, @attach) = @$_;
292 $res = _attach @$registry, $klass, @attach;
293 }
294
295 $obj->{$name} = \%arg;
296 } else {
297 warn "object uses attachment '$name' that is not available, postponing.\n";
298 }
299
300 $obj->{_attachment}{$name} = undef;
301
302 $res->{attachment} = $name;
303 $res
304}
305
183sub cf::object::attach { 306*cf::object::attach =
184 die; 307*cf::player::attach =
185} 308*cf::map::attach = sub {
309 my ($obj, $name, %arg) = @_;
310
311 _attach_attachment $obj, $name, %arg;
312};
313
314# all those should be optimised
315*cf::object::detach =
316*cf::player::detach =
317*cf::map::detach = sub {
318 my ($obj, $name) = @_;
319
320 delete $obj->{_attachment}{$name};
321 reattach ($obj);
322};
323
324*cf::object::attached =
325*cf::player::attached =
326*cf::map::attached = sub {
327 my ($obj, $name) = @_;
328
329 exists $obj->{_attachment}{$name}
330};
186 331
187sub attach_global { 332sub attach_global {
188 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 333 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
189} 334}
190 335
191sub attach_to_type { 336sub attach_to_type {
192 my $type = shift; 337 my $type = shift;
338 my $subtype = shift;
339
193 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_ 340 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
194} 341}
195 342
196sub attach_to_objects { 343sub attach_to_objects {
197 _attach @CB_OBJECT, KLASS_OBJECT, @_ 344 _attach @CB_OBJECT, KLASS_OBJECT, @_
198} 345}
203 350
204sub attach_to_maps { 351sub attach_to_maps {
205 _attach @CB_MAP, KLASS_MAP, @_ 352 _attach @CB_MAP, KLASS_MAP, @_
206} 353}
207 354
355sub register_attachment {
356 my $name = shift;
357
358 $attachment{$name} = [[KLASS_OBJECT, @_]];
359}
360
361sub register_player_attachment {
362 my $name = shift;
363
364 $attachment{$name} = [[KLASS_PLAYER, @_]];
365}
366
367sub register_map_attachment {
368 my $name = shift;
369
370 $attachment{$name} = [[KLASS_MAP, @_]];
371}
372
208our $override; 373our $override;
374our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
209 375
210sub override() { 376sub override {
211 $override = 1 377 $override = 1;
378 @invoke_results = ();
212} 379}
213 380
214sub invoke { 381sub do_invoke {
215 my $event = shift; 382 my $event = shift;
216 my $callbacks = shift; 383 my $callbacks = shift;
384
385 @invoke_results = ();
217 386
218 local $override; 387 local $override;
219 388
220 for (@$callbacks) { 389 for (@$callbacks) {
221 eval { &{$_->[1]} }; 390 eval { &{$_->[1]} };
230 } 399 }
231 400
232 0 401 0
233} 402}
234 403
404=item $bool = cf::invoke EVENT_GLOBAL_XXX, ...
405
406=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
407
408=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
409
410=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
411
412Generate a global/object/player/map-specific event with the given arguments.
413
414This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
415removed in future versions), and there is no public API to access override
416results (if you must, access C<@cf::invoke_results> directly).
417
418=back
419
420=head2 methods valid for all pointers
421
422=over 4
423
424=item $object->valid
425
426=item $player->valid
427
428=item $map->valid
429
430Just because you have a perl object does not mean that the corresponding
431C-level object still exists. If you try to access an object that has no
432valid C counterpart anymore you get an exception at runtime. This method
433can be used to test for existence of the C object part without causing an
434exception.
435
436=back
437
438=cut
439
440*cf::object::valid =
441*cf::player::valid =
442*cf::map::valid = \&cf::_valid;
443
444#############################################################################
445# object support
446
447sub instantiate {
448 my ($obj, $data) = @_;
449
450 $data = from_json $data;
451
452 for (@$data) {
453 my ($name, $args) = @$_;
454
455 $obj->attach ($name, %{$args || {} });
456 }
457}
458
459# basically do the same as instantiate, without calling instantiate
460sub reattach {
461 my ($obj) = @_;
462 my $registry = $obj->registry;
463
464 @$registry = ();
465
466 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
467
468 for my $name (keys %{ $obj->{_attachment} || {} }) {
469 if (my $attach = $attachment{$name}) {
470 for (@$attach) {
471 my ($klass, @attach) = @$_;
472 _attach @$registry, $klass, @attach;
473 }
474 } else {
475 warn "object uses attachment '$name' that is not available, postponing.\n";
476 }
477 }
478}
479
480sub object_freezer_save {
481 my ($filename, $objs) = @_;
482
483 if (@$objs) {
484 open my $fh, ">:raw", "$filename.pst~";
485 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
486 close $fh;
487 chmod SAVE_MODE, "$filename.pst~";
488 rename "$filename.pst~", "$filename.pst";
489 } else {
490 unlink "$filename.pst";
491 }
492
493 chmod SAVE_MODE, "$filename~";
494 rename "$filename~", $filename;
495}
496
497sub object_thawer_load {
498 my ($filename) = @_;
499
500 open my $fh, "<:raw:perlio", "$filename.pst"
501 or return;
502
503 eval { local $/; (Storable::thaw <$fh>)->{objs} }
504}
505
506attach_to_objects
507 prio => -1000000,
508 on_clone => sub {
509 my ($src, $dst) = @_;
510
511 @{$dst->registry} = @{$src->registry};
512
513 %$dst = %$src;
514
515 %{$dst->{_attachment}} = %{$src->{_attachment}}
516 if exists $src->{_attachment};
517 },
518;
519
235############################################################################# 520#############################################################################
236# old plug-in events 521# old plug-in events
237 522
238sub inject_event { 523sub inject_event {
239 my $extension = shift; 524 my $extension = shift;
284} 569}
285 570
286sub register { 571sub register {
287 my ($base, $pkg) = @_; 572 my ($base, $pkg) = @_;
288 573
289 for my $idx (0 .. $#PLUGIN_EVENT) { 574 #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} 575}
296 576
297sub load_extension { 577sub load_extension {
298 my ($path) = @_; 578 my ($path) = @_;
299 579
330 my ($pkg) = @_; 610 my ($pkg) = @_;
331 611
332 warn "removing extension $pkg\n"; 612 warn "removing extension $pkg\n";
333 613
334 # remove hooks 614 # remove hooks
615 #TODO
335 for my $idx (0 .. $#PLUGIN_EVENT) { 616# for my $idx (0 .. $#PLUGIN_EVENT) {
336 delete $hook[$idx]{$pkg}; 617# delete $hook[$idx]{$pkg};
337 } 618# }
338 619
339 # remove commands 620 # remove commands
340 for my $name (keys %command) { 621 for my $name (keys %command) {
341 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 622 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
342 623
408 Symbol::delete_package $k; 689 Symbol::delete_package $k;
409 } 690 }
410 691
411 # 4. get rid of safe::, as good as possible 692 # 4. get rid of safe::, as good as possible
412 Symbol::delete_package "safe::$_" 693 Symbol::delete_package "safe::$_"
413 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region); 694 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
414 695
415 # 5. remove register_script_function callbacks 696 # 5. remove register_script_function callbacks
416 # TODO 697 # TODO
417 698
418 # 6. unload cf.pm "a bit" 699 # 6. unload cf.pm "a bit"
448 }; 729 };
449 } 730 }
450}; 731};
451 732
452############################################################################# 733#############################################################################
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> 734# extcmd framework, basically convert ext <msg>
469# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 735# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
470 736
471attach_global 737attach_to_players
472 on_extcmd => sub { 738 on_extcmd => sub {
473 my ($pl, $buf) = @_; 739 my ($pl, $buf) = @_;
474 740
475 my $msg = eval { from_json $buf }; 741 my $msg = eval { from_json $buf };
476 742
495 my ($map) = @_; 761 my ($map) = @_;
496 762
497 my $path = $map->tmpname; 763 my $path = $map->tmpname;
498 defined $path or return; 764 defined $path or return;
499 765
500 unlink "$path.cfperl"; 766 unlink "$path.pst";
501}; 767};
502 768
769# old style persistent data, TODO: remove #d#
503*cf::mapsupport::on_swapin = 770*cf::mapsupport::on_swapin = sub {
504*cf::mapsupport::on_load = sub {
505 my ($map) = @_; 771 my ($map) = @_;
506 772
507 my $path = $map->tmpname; 773 my $path = $map->tmpname;
508 $path = $map->path unless defined $path; 774 $path = $map->path unless defined $path;
509 775
776 warn "$path.cfperl\n";#d#
777
510 open my $fh, "<:raw", "$path.cfperl" 778 open my $fh, "<:raw", "$path.cfperl"
511 or return; # no perl data 779 or return; # no perl data
512 780
513 my $data = Storable::thaw do { local $/; <$fh> }; 781 my $data = Storable::thaw do { local $/; <$fh> };
514 782
515 $data->{version} <= 1 783 $data->{version} <= 1
516 or return; # too new 784 or return; # too new
517 785
518 $map->_set_obs ($data->{obs}); 786 $map->_set_obs ($data->{obs});
519}; 787 $map->invoke (EVENT_MAP_UPGRADE);
520
521*cf::mapsupport::on_swapout = sub {
522 my ($map) = @_;
523
524 my $path = $map->tmpname;
525 $path = $map->path unless defined $path;
526
527 my $obs = $map->_get_obs;
528
529 if (defined $obs) {
530 open my $fh, ">:raw", "$path.cfperl"
531 or die "$path.cfperl: $!";
532
533 stat $path;
534
535 print $fh Storable::nfreeze {
536 size => (stat _)[7],
537 time => (stat _)[9],
538 version => 1,
539 obs => $obs,
540 };
541
542 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
543 } else {
544 unlink "$path.cfperl";
545 }
546}; 788};
547 789
548attach_to_maps prio => -10000, package => cf::mapsupport::; 790attach_to_maps prio => -10000, package => cf::mapsupport::;
549 791
550############################################################################# 792#############################################################################
563 $o->set_ob_key_value ("_perl_data"); 805 $o->set_ob_key_value ("_perl_data");
564 806
565 %$o = %{ Storable::thaw pack "H*", $value }; 807 %$o = %{ Storable::thaw pack "H*", $value };
566 } 808 }
567 } 809 }
568 },
569 on_save => sub {
570 my ($pl, $path) = @_;
571
572 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
573 for grep %$_, all_objects $pl->ob;
574 }, 810 },
575; 811;
576 812
577############################################################################# 813#############################################################################
578# core extensions - in perl 814# core extensions - in perl
717 $TICK_WATCHER->at ($NEXT_TICK); 953 $TICK_WATCHER->at ($NEXT_TICK);
718 $TICK_WATCHER->start; 954 $TICK_WATCHER->start;
719 }, 955 },
720); 956);
721 957
958_reload_2;
959
7221 9601
723 961

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines