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.47 by root, Sun Aug 27 13:02:04 2006 UTC vs.
Revision 1.61 by root, Sun Sep 3 22:45:56 2006 UTC

… …
72 72
73@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 73@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
74 74
75# 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
76# within the Safe compartment. 76# within the Safe compartment.
77for 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)) {
78 no strict 'refs'; 78 no strict 'refs';
79 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 79 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
80} 80}
81 81
82$Event::DIED = sub { 82$Event::DIED = sub {
… …
105} 105}
106 106
107############################################################################# 107#############################################################################
108# "new" plug-in system 108# "new" plug-in system
109 109
110=head3 EVENTS AND OBJECT ATTACHMENTS
111
112=over 4
113
114=item $object->attach ($attachment, key => $value...)
115
110=item $object->attach ($attachment, ...) 116=item $object->detach ($attachment)
111 117
112Attach a pre-registered attachment to an object. 118Attach/detach a pre-registered attachment to an object.
113 119
120=item $player->attach ($attachment, key => $value...)
121
114=item $player->attach ($attachment, ...) 122=item $player->detach ($attachment)
115 123
116Attach a pre-registered attachment to a player. 124Attach/detach a pre-registered attachment to a player.
117 125
118=item $map->attach ($attachment, ...) # not yet persistent 126=item $map->attach ($attachment, key => $value...)
119 127
128=item $map->detach ($attachment)
129
120Attach 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.
121 139
122=item cf::attach_global ... 140=item cf::attach_global ...
123 141
124Attach handlers for global events. 142Attach handlers for global events.
125 143
… …
173=item cf::attach_to_maps ... 191=item cf::attach_to_maps ...
174 192
175Attach handlers to all maps. 193Attach handlers to all maps.
176 194
177=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.
178 209
179=cut 210=cut
180 211
181# 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
182our @CB_GLOBAL = (); # registry for all global events 213our @CB_GLOBAL = (); # registry for all global events
… …
245 276
246 \%undo 277 \%undo
247} 278}
248 279
249sub _attach_attachment { 280sub _attach_attachment {
250 my ($obj, $name, @args) = @_; 281 my ($obj, $name, %arg) = @_;
282
283 return if exists $obj->{_attachment}{$name};
251 284
252 my $res; 285 my $res;
253 286
254 if (my $attach = $attachment{$name}) { 287 if (my $attach = $attachment{$name}) {
255 my $registry = $obj->registry; 288 my $registry = $obj->registry;
… …
257 for (@$attach) { 290 for (@$attach) {
258 my ($klass, @attach) = @$_; 291 my ($klass, @attach) = @$_;
259 $res = _attach @$registry, $klass, @attach; 292 $res = _attach @$registry, $klass, @attach;
260 } 293 }
261 294
262 if (my $cb = delete $registry->[EVENT_OBJECT_INSTANTIATE]) { 295 $obj->{$name} = \%arg;
263 for (@$cb) {
264 eval { $_->[1]->($obj, @args); };
265 if ($@) {
266 warn "$@";
267 warn "... while processing '$name' instantiate with args <@args>.\n";
268 }
269 }
270 }
271 } else { 296 } else {
272 warn "object uses attachment '$name' that is not available, postponing.\n"; 297 warn "object uses attachment '$name' that is not available, postponing.\n";
273 } 298 }
274 299
275 push @{$obj->{_attachment}}, $name; 300 $obj->{_attachment}{$name} = undef;
276 301
277 $res->{attachment} = $name; 302 $res->{attachment} = $name;
278 $res 303 $res
279} 304}
280 305
281sub cf::object::attach { 306*cf::object::attach =
307*cf::player::attach =
308*cf::map::attach = sub {
282 my ($obj, $name, @args) = @_; 309 my ($obj, $name, %arg) = @_;
283 310
284 _attach_attachment $obj, $name, @args; 311 _attach_attachment $obj, $name, %arg;
285} 312};
286 313
314# all those should be optimised
315*cf::object::detach =
287sub cf::player::attach { 316*cf::player::detach =
317*cf::map::detach = sub {
288 my ($obj, $name, @args) = @_; 318 my ($obj, $name) = @_;
289 319
290 _attach_attachment KLASS_PLAYER, $obj, $name, @args; 320 delete $obj->{_attachment}{$name};
291} 321 reattach ($obj);
322};
292 323
293sub cf::map::attach { 324*cf::object::attached =
325*cf::player::attached =
326*cf::map::attached = sub {
294 my ($obj, $name, @args) = @_; 327 my ($obj, $name) = @_;
295 328
296 _attach_attachment KLASS_MAP, $obj, $name, @args; 329 exists $obj->{_attachment}{$name}
297} 330};
298 331
299sub attach_global { 332sub attach_global {
300 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 333 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
301} 334}
302 335
… …
321 354
322sub register_attachment { 355sub register_attachment {
323 my $name = shift; 356 my $name = shift;
324 357
325 $attachment{$name} = [[KLASS_OBJECT, @_]]; 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, @_]];
326} 371}
327 372
328our $override; 373our $override;
329our @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?
330 375
… …
354 } 399 }
355 400
356 0 401 0
357} 402}
358 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
359############################################################################# 444#############################################################################
360# object support 445# object support
361 446
362sub instantiate { 447sub instantiate {
363 my ($obj, $data) = @_; 448 my ($obj, $data) = @_;
364 449
365 $data = from_json $data; 450 $data = from_json $data;
366 451
367 for (@$data) { 452 for (@$data) {
368 my ($name, $args) = @$_; 453 my ($name, $args) = @$_;
369 attach $obj, $name, @{$args || [] }; 454
455 $obj->attach ($name, %{$args || {} });
370 } 456 }
371} 457}
372 458
373# basically do the same as instantiate, without calling instantiate 459# basically do the same as instantiate, without calling instantiate
374sub reattach { 460sub reattach {
375 my ($obj) = @_; 461 my ($obj) = @_;
376 my $registry = $obj->registry; 462 my $registry = $obj->registry;
377 463
378 @$registry = (); 464 @$registry = ();
379 465
466 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
467
380 for my $name (@{ $obj->{_attachment} }) { 468 for my $name (keys %{ $obj->{_attachment} || {} }) {
381 if (my $attach = $attachment{$name}) { 469 if (my $attach = $attachment{$name}) {
382 for (@$attach) { 470 for (@$attach) {
383 my ($klass, @attach) = @$_; 471 my ($klass, @attach) = @$_;
384 _attach @$registry, $klass, @attach; 472 _attach @$registry, $klass, @attach;
385 } 473 }
… …
388 } 476 }
389 } 477 }
390} 478}
391 479
392sub object_freezer_save { 480sub object_freezer_save {
393 my ($filename, $objs) = @_; 481 my ($filename, $rdata, $objs) = @_;
394 482
395 $filename .= ".pst"; 483 if (length $$rdata) {
484 warn sprintf "saving %s (%d,%d)\n",
485 $filename, length $$rdata, scalar @$objs;
396 486
397 if (@$objs) {
398 open my $fh, ">:raw", "$filename~"; 487 if (open my $fh, ">:raw", "$filename~") {
399 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;
400 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 494 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
401 close $fh; 495 close $fh;
496 rename "$filename.pst~", "$filename.pst";
497 } else {
498 unlink "$filename.pst";
499 }
500
402 rename "$filename~", $filename; 501 rename "$filename~", $filename;
502 } else {
503 warn "FATAL: $filename~: $!\n";
504 }
403 } else { 505 } else {
404 unlink $filename; 506 unlink $filename;
507 unlink "$filename.pst";
405 } 508 }
406} 509}
407 510
408sub object_thawer_load { 511sub object_thawer_load {
409 my ($filename) = @_; 512 my ($filename) = @_;
410 513
514 local $/;
515
516 my $av;
517
518 #TODO: use sysread etc.
519 if (open my $data, "<:raw:perlio", $filename) {
520 $data = <$data>;
411 open my $fh, "<:raw:perlio", "$filename.pst" 521 if (open my $pst, "<:raw:perlio", "$filename.pst") {
412 or return; 522 $av = eval { (Storable::thaw <$pst>)->{objs} };
523 }
524 return ($data, $av);
525 }
413 526
414 eval { local $/; (Storable::thaw <$fh>)->{objs} } 527 ()
415} 528}
416 529
417attach_to_objects 530attach_to_objects
418 prio => -1000000, 531 prio => -1000000,
419 on_clone => sub { 532 on_clone => sub {
… …
421 534
422 @{$dst->registry} = @{$src->registry}; 535 @{$dst->registry} = @{$src->registry};
423 536
424 %$dst = %$src; 537 %$dst = %$src;
425 538
426 $dst->{_attachment} = [@{ $src->{_attachment} }] 539 %{$dst->{_attachment}} = %{$src->{_attachment}}
427 if exists $src->{_attachment}; 540 if exists $src->{_attachment};
428 }, 541 },
429; 542;
430 543
431############################################################################# 544#############################################################################
… …
615 #Symbol::delete_package __PACKAGE__; 728 #Symbol::delete_package __PACKAGE__;
616 729
617 # 7. reload cf.pm 730 # 7. reload cf.pm
618 $msg->("reloading cf.pm"); 731 $msg->("reloading cf.pm");
619 require cf; 732 require cf;
733
734 $msg->("load extensions");
735 cf::load_extensions;
620 }; 736 };
621 $msg->($@) if $@; 737 $msg->($@) if $@;
622 738
623 $msg->("reloaded"); 739 $msg->("reloaded");
624}; 740};
… …
672 my ($map) = @_; 788 my ($map) = @_;
673 789
674 my $path = $map->tmpname; 790 my $path = $map->tmpname;
675 defined $path or return; 791 defined $path or return;
676 792
677 unlink "$path.cfperl";
678 unlink "$path.pst"; 793 unlink "$path.pst";
679}; 794};
680 795
681*cf::mapsupport::on_swapin =
682*cf::mapsupport::on_load = sub {
683 my ($map) = @_;
684
685 my $path = $map->tmpname;
686 $path = $map->path unless defined $path;
687
688 open my $fh, "<:raw", "$path.cfperl"
689 or return; # no perl data
690
691 my $data = Storable::thaw do { local $/; <$fh> };
692
693 $data->{version} <= 1
694 or return; # too new
695
696 $map->_set_obs ($data->{obs});
697};
698
699attach_to_maps prio => -10000, package => cf::mapsupport::; 796attach_to_maps prio => -10000, package => cf::mapsupport::;
700 797
701############################################################################# 798#############################################################################
702# load/save perl data associated with player->ob objects 799# load/save perl data associated with player->ob objects
703 800
704sub all_objects(@) { 801sub all_objects(@) {
705 @_, map all_objects ($_->inv), @_ 802 @_, map all_objects ($_->inv), @_
706} 803}
707 804
805# TODO: compatibility cruft, remove when no longer needed
708attach_to_players 806attach_to_players
709 on_load => sub { 807 on_load => sub {
710 my ($pl, $path) = @_; 808 my ($pl, $path) = @_;
711 809
712 for my $o (all_objects $pl->ob) { 810 for my $o (all_objects $pl->ob) {
… …
833 931
834############################################################################# 932#############################################################################
835# the server's main() 933# the server's main()
836 934
837sub main { 935sub main {
936 load_extensions;
838 Event::loop; 937 Event::loop;
839} 938}
840 939
841############################################################################# 940#############################################################################
842# initialisation 941# initialisation
843 942
844register "<global>", __PACKAGE__; 943register "<global>", __PACKAGE__;
845 944
846unshift @INC, $LIBDIR; 945unshift @INC, $LIBDIR;
847
848load_extensions;
849 946
850$TICK_WATCHER = Event->timer ( 947$TICK_WATCHER = Event->timer (
851 prio => 1, 948 prio => 1,
852 at => $NEXT_TICK || 1, 949 at => $NEXT_TICK || 1,
853 cb => sub { 950 cb => sub {

Diff Legend

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