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.58 by root, Wed Aug 30 12:08:15 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, $objs) = @_;
384 warn "freeze $filename\n";#d#
385 use Data::Dumper; print Dumper $objs;
386
387 $filename .= ".pst";
388 482
389 if (@$objs) { 483 if (@$objs) {
390 open my $fh, ">:raw", "$filename~"; 484 open my $fh, ">:raw", "$filename.pst~";
391 chmod $fh, SAVE_MODE;
392 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 485 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
393 close $fh; 486 close $fh;
487 chmod SAVE_MODE, "$filename.pst~";
394 rename "$filename~", $filename; 488 rename "$filename.pst~", "$filename.pst";
395 } else { 489 } else {
396 unlink $filename; 490 unlink "$filename.pst";
397 } 491 }
492
493 chmod SAVE_MODE, "$filename~";
494 rename "$filename~", $filename;
398} 495}
399 496
400sub object_thawer_load { 497sub object_thawer_load {
401 my ($filename) = @_; 498 my ($filename) = @_;
402
403 warn "thaw $filename\n";#d#
404 499
405 open my $fh, "<:raw:perlio", "$filename.pst" 500 open my $fh, "<:raw:perlio", "$filename.pst"
406 or return; 501 or return;
407 502
408 eval { local $/; (Storable::thaw <$fh>)->{objs} } 503 eval { local $/; (Storable::thaw <$fh>)->{objs} }
… …
412 prio => -1000000, 507 prio => -1000000,
413 on_clone => sub { 508 on_clone => sub {
414 my ($src, $dst) = @_; 509 my ($src, $dst) = @_;
415 510
416 @{$dst->registry} = @{$src->registry}; 511 @{$dst->registry} = @{$src->registry};
417 warn "registry clone ", join ":", @{$src->registry};#d#
418 512
419 %$dst = %$src; 513 %$dst = %$src;
420 514
421 $dst->{_attachment} = [@{ $src->{_attachment} }] 515 %{$dst->{_attachment}} = %{$src->{_attachment}}
422 if exists $src->{_attachment}; 516 if exists $src->{_attachment};
423
424 warn "clone<@_>\n";#d#
425 }, 517 },
426; 518;
427 519
428############################################################################# 520#############################################################################
429# old plug-in events 521# old plug-in events
… …
669 my ($map) = @_; 761 my ($map) = @_;
670 762
671 my $path = $map->tmpname; 763 my $path = $map->tmpname;
672 defined $path or return; 764 defined $path or return;
673 765
674 unlink "$path.cfperl";
675 unlink "$path.pst"; 766 unlink "$path.pst";
676};
677
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}; 767};
695 768
696attach_to_maps prio => -10000, package => cf::mapsupport::; 769attach_to_maps prio => -10000, package => cf::mapsupport::;
697 770
698############################################################################# 771#############################################################################
… …
859 $TICK_WATCHER->at ($NEXT_TICK); 932 $TICK_WATCHER->at ($NEXT_TICK);
860 $TICK_WATCHER->start; 933 $TICK_WATCHER->start;
861 }, 934 },
862); 935);
863 936
937_reload_2;
938
8641 9391
865 940

Diff Legend

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