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.46 by root, Sun Aug 27 16:15:12 2006 UTC vs.
Revision 1.60 by root, Thu Aug 31 06:23:19 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 %PROP_TYPE; 20our %PROP_TYPE;
19our %PROP_IDX; 21our %PROP_IDX;
20our $LIBDIR = maps_directory "perl"; 22our $LIBDIR = maps_directory "perl";
… …
70 72
71@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 73@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
72 74
73# 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
74# within the Safe compartment. 76# within the Safe compartment.
75for my $pkg (qw(cf::object 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)) {
76 no strict 'refs'; 78 no strict 'refs';
77 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 79 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
78} 80}
79 81
80$Event::DIED = sub { 82$Event::DIED = sub {
… …
103} 105}
104 106
105############################################################################# 107#############################################################################
106# "new" plug-in system 108# "new" plug-in system
107 109
110=head3 EVENTS AND OBJECT ATTACHMENTS
111
112=over 4
113
114=item $object->attach ($attachment, key => $value...)
115
108=item $object->attach ($attachment, ...) 116=item $object->detach ($attachment)
109 117
110Attach a pre-registered attachment to an object. 118Attach/detach a pre-registered attachment to an object.
111 119
120=item $player->attach ($attachment, key => $value...)
121
112=item $player->attach ($attachment, ...) 122=item $player->detach ($attachment)
113 123
114Attach a pre-registered attachment to a player. 124Attach/detach a pre-registered attachment to a player.
115 125
116=item $map->attach ($attachment, ...) # not yet persistent 126=item $map->attach ($attachment, key => $value...)
117 127
128=item $map->detach ($attachment)
129
118Attach a pre-registered attachment to a map. 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.
119 139
120=item cf::attach_global ... 140=item cf::attach_global ...
121 141
122Attach handlers for global events. 142Attach handlers for global events.
123 143
… …
150package and register them. Only handlers for eevents supported by the 170package and register them. Only handlers for eevents supported by the
151object/class are recognised. 171object/class are recognised.
152 172
153=back 173=back
154 174
155=item cf::attach_to_type $object_type, ... 175=item cf::attach_to_type $object_type, $subtype, ...
156 176
157Attach handlers for a specific object type (e.g. TRANSPORT). 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.
158 180
159=item cf::attach_to_objects ... 181=item cf::attach_to_objects ...
160 182
161Attach handlers to all objects. Do not use this except for debugging or 183Attach handlers to all objects. Do not use this except for debugging or
162very rare events, as handlers are (obviously) called for I<all> objects in 184very rare events, as handlers are (obviously) called for I<all> objects in
… …
169=item cf::attach_to_maps ... 191=item cf::attach_to_maps ...
170 192
171Attach handlers to all maps. 193Attach handlers to all maps.
172 194
173=item cf:register_attachment $name, ... 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.
174 209
175=cut 210=cut
176 211
177# 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
178our @CB_GLOBAL = (); # registry for all global events 213our @CB_GLOBAL = (); # registry for all global events
… …
241 276
242 \%undo 277 \%undo
243} 278}
244 279
245sub _attach_attachment { 280sub _attach_attachment {
246 my ($klass, $obj, $name, @args) = q_; 281 my ($obj, $name, %arg) = @_;
282
283 return if exists $obj->{_attachment}{$name};
247 284
248 my $res; 285 my $res;
249 286
250 if (my $attach = $attachment{$name}) { 287 if (my $attach = $attachment{$name}) {
251 my $registry = $obj->registry; 288 my $registry = $obj->registry;
252 289
290 for (@$attach) {
291 my ($klass, @attach) = @$_;
253 $res = _attach @$registry, $klass, @$attach; 292 $res = _attach @$registry, $klass, @attach;
254
255 if (my $cb = delete $registry->[EVENT_OBJECT_INSTANTIATE]) {
256 for (@$cb) {
257 eval { $_->[1]->($obj, @args); };
258 if ($@) {
259 warn "$@";
260 warn "... while processing '$name' instantiate with args <@args>.\n";
261 }
262 }
263 } 293 }
294
295 $obj->{$name} = \%arg;
264 } else { 296 } else {
265 warn "object uses attachment '$name' that is not available, postponing.\n"; 297 warn "object uses attachment '$name' that is not available, postponing.\n";
266 } 298 }
267 299
268 push @{$obj->{_attachment}}, $name; 300 $obj->{_attachment}{$name} = undef;
269 301
270 $res->{attachment} = $name; 302 $res->{attachment} = $name;
271 $res 303 $res
272} 304}
273 305
274sub cf::object::attach { 306*cf::object::attach =
307*cf::player::attach =
308*cf::map::attach = sub {
275 my ($obj, $name, @args) = @_; 309 my ($obj, $name, %arg) = @_;
276 310
277 _attach_attachment KLASS_OBJECT, $obj, $name, @args; 311 _attach_attachment $obj, $name, %arg;
278} 312};
279 313
314# all those should be optimised
315*cf::object::detach =
280sub cf::player::attach { 316*cf::player::detach =
317*cf::map::detach = sub {
281 my ($obj, $name, @args) = @_; 318 my ($obj, $name) = @_;
282 319
283 _attach_attachment KLASS_PLAYER, $obj, $name, @args; 320 delete $obj->{_attachment}{$name};
284} 321 reattach ($obj);
322};
285 323
286sub cf::map::attach { 324*cf::object::attached =
325*cf::player::attached =
326*cf::map::attached = sub {
287 my ($obj, $name, @args) = @_; 327 my ($obj, $name) = @_;
288 328
289 _attach_attachment KLASS_MAP, $obj, $name, @args; 329 exists $obj->{_attachment}{$name}
290} 330};
291 331
292sub attach_global { 332sub attach_global {
293 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 333 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
294} 334}
295 335
296sub attach_to_type { 336sub attach_to_type {
297 my $type = shift; 337 my $type = shift;
338 my $subtype = shift;
298 339
299 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_ 340 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
300} 341}
301 342
302sub attach_to_objects { 343sub attach_to_objects {
303 _attach @CB_OBJECT, KLASS_OBJECT, @_ 344 _attach @CB_OBJECT, KLASS_OBJECT, @_
304} 345}
… …
312} 353}
313 354
314sub register_attachment { 355sub register_attachment {
315 my $name = shift; 356 my $name = shift;
316 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
317 $attachment{$name} = [@_]; 370 $attachment{$name} = [[KLASS_MAP, @_]];
318} 371}
319 372
320our $override; 373our $override;
321our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 374our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
322 375
… …
346 } 399 }
347 400
348 0 401 0
349} 402}
350 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
351############################################################################# 444#############################################################################
352# object support 445# object support
353 446
354sub instantiate { 447sub instantiate {
355 my ($obj, $data) = @_; 448 my ($obj, $data) = @_;
356 449
357 $data = from_json $data; 450 $data = from_json $data;
358 451
359 for (@$data) { 452 for (@$data) {
360 my ($name, $args) = @$_; 453 my ($name, $args) = @$_;
361 attach $obj, $name, @{$args || [] }; 454
455 $obj->attach ($name, %{$args || {} });
362 } 456 }
363} 457}
364 458
365# basically do the same as instantiate, without calling instantiate 459# basically do the same as instantiate, without calling instantiate
366sub reattach { 460sub reattach {
367 warn "reattach<@_>\n";#d#
368 my ($obj) = @_; 461 my ($obj) = @_;
369 my $registry = $obj->registry; 462 my $registry = $obj->registry;
370 463
464 @$registry = ();
465
466 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
467
371 for my $name (@{ $obj->{_attachment} }) { 468 for my $name (keys %{ $obj->{_attachment} || {} }) {
372 if (my $attach = $attachment{$name}) { 469 if (my $attach = $attachment{$name}) {
470 for (@$attach) {
471 my ($klass, @attach) = @$_;
373 _attach @$registry, KLASS_OBJECT, @$attach; 472 _attach @$registry, $klass, @attach;
473 }
374 } else { 474 } else {
375 warn "object uses attachment '$name' that is not available, postponing.\n"; 475 warn "object uses attachment '$name' that is not available, postponing.\n";
376 } 476 }
377 } 477 }
378
379 warn "reattach<@_, $_>\n";
380} 478}
381 479
382sub object_freezer_save { 480sub object_freezer_save {
383 my ($filename, $objs) = @_; 481 my ($filename, $rdata, $objs) = @_;
384 warn "freeze $filename\n";#d#
385 use Data::Dumper; print Dumper $objs;
386 482
387 $filename .= ".pst"; 483 if (length $$rdata) {
484 warn sprintf "saving %s (%d,%d)\n",
485 $filename, length $$rdata, scalar @$objs;
388 486
389 if (@$objs) {
390 open my $fh, ">:raw", "$filename~"; 487 if (open my $fh, ">:raw", "$filename~") {
391 chmod $fh, SAVE_MODE; 488 chmod SAVE_MODE, $fh;
489 syswrite $fh, $$rdata;
490 close $fh;
491
492 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
493 chmod SAVE_MODE, $fh;
392 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 494 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
393 close $fh; 495 close $fh;
496 rename "$filename.pst~", "$filename.pst";
497 } else {
498 unlink "$filename.pst";
499 }
500
394 rename "$filename~", $filename; 501 rename "$filename~", $filename;
502 } else {
503 warn "FATAL: $filename~: $!\n";
504 }
395 } else { 505 } else {
396 unlink $filename; 506 unlink $filename;
507 unlink "$filename.pst";
397 } 508 }
398} 509}
399 510
400sub object_thawer_load { 511sub object_thawer_load {
401 my ($filename) = @_; 512 my ($filename) = @_;
402
403 warn "thaw $filename\n";#d#
404 513
405 open my $fh, "<:raw:perlio", "$filename.pst" 514 open my $fh, "<:raw:perlio", "$filename.pst"
406 or return; 515 or return;
407 516
408 eval { local $/; (Storable::thaw <$fh>)->{objs} } 517 eval { local $/; (Storable::thaw <$fh>)->{objs} }
… …
412 prio => -1000000, 521 prio => -1000000,
413 on_clone => sub { 522 on_clone => sub {
414 my ($src, $dst) = @_; 523 my ($src, $dst) = @_;
415 524
416 @{$dst->registry} = @{$src->registry}; 525 @{$dst->registry} = @{$src->registry};
417 warn "registry clone ", join ":", @{$src->registry};#d#
418 526
419 %$dst = %$src; 527 %$dst = %$src;
420 528
421 $dst->{_attachment} = [@{ $src->{_attachment} }] 529 %{$dst->{_attachment}} = %{$src->{_attachment}}
422 if exists $src->{_attachment}; 530 if exists $src->{_attachment};
423
424 warn "clone<@_>\n";#d#
425 }, 531 },
426; 532;
427 533
428############################################################################# 534#############################################################################
429# old plug-in events 535# old plug-in events
… …
669 my ($map) = @_; 775 my ($map) = @_;
670 776
671 my $path = $map->tmpname; 777 my $path = $map->tmpname;
672 defined $path or return; 778 defined $path or return;
673 779
674 unlink "$path.cfperl";
675 unlink "$path.pst"; 780 unlink "$path.pst";
676}; 781};
677 782
678*cf::mapsupport::on_swapin =
679*cf::mapsupport::on_load = sub {
680 my ($map) = @_;
681
682 my $path = $map->tmpname;
683 $path = $map->path unless defined $path;
684
685 open my $fh, "<:raw", "$path.cfperl"
686 or return; # no perl data
687
688 my $data = Storable::thaw do { local $/; <$fh> };
689
690 $data->{version} <= 1
691 or return; # too new
692
693 $map->_set_obs ($data->{obs});
694};
695
696attach_to_maps prio => -10000, package => cf::mapsupport::; 783attach_to_maps prio => -10000, package => cf::mapsupport::;
697 784
698############################################################################# 785#############################################################################
699# load/save perl data associated with player->ob objects 786# load/save perl data associated with player->ob objects
700 787
701sub all_objects(@) { 788sub all_objects(@) {
702 @_, map all_objects ($_->inv), @_ 789 @_, map all_objects ($_->inv), @_
703} 790}
704 791
792# TODO: compatibility cruft, remove when no longer needed
705attach_to_players 793attach_to_players
706 on_load => sub { 794 on_load => sub {
707 my ($pl, $path) = @_; 795 my ($pl, $path) = @_;
708 796
709 for my $o (all_objects $pl->ob) { 797 for my $o (all_objects $pl->ob) {
… …
859 $TICK_WATCHER->at ($NEXT_TICK); 947 $TICK_WATCHER->at ($NEXT_TICK);
860 $TICK_WATCHER->start; 948 $TICK_WATCHER->start;
861 }, 949 },
862); 950);
863 951
952_reload_2;
953
8641 9541
865 955

Diff Legend

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