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.57 by root, Wed Aug 30 11:21:24 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 unlink "$filename.cfperl";
488 chmod SAVE_MODE, "$filename.pst~";
394 rename "$filename~", $filename; 489 rename "$filename.pst~", "$filename.pst";
395 } else { 490 } else {
396 unlink $filename; 491 unlink "$filename.pst";
397 } 492 }
493
494 chmod SAVE_MODE, "$filename~";
495 rename "$filename~", $filename;
398} 496}
399 497
400sub object_thawer_load { 498sub object_thawer_load {
401 my ($filename) = @_; 499 my ($filename) = @_;
402
403 warn "thaw $filename\n";#d#
404 500
405 open my $fh, "<:raw:perlio", "$filename.pst" 501 open my $fh, "<:raw:perlio", "$filename.pst"
406 or return; 502 or return;
407 503
408 eval { local $/; (Storable::thaw <$fh>)->{objs} } 504 eval { local $/; (Storable::thaw <$fh>)->{objs} }
… …
412 prio => -1000000, 508 prio => -1000000,
413 on_clone => sub { 509 on_clone => sub {
414 my ($src, $dst) = @_; 510 my ($src, $dst) = @_;
415 511
416 @{$dst->registry} = @{$src->registry}; 512 @{$dst->registry} = @{$src->registry};
417 warn "registry clone ", join ":", @{$src->registry};#d#
418 513
419 %$dst = %$src; 514 %$dst = %$src;
420 515
421 $dst->{_attachment} = [@{ $src->{_attachment} }] 516 %{$dst->{_attachment}} = %{$src->{_attachment}}
422 if exists $src->{_attachment}; 517 if exists $src->{_attachment};
423
424 warn "clone<@_>\n";#d#
425 }, 518 },
426; 519;
427 520
428############################################################################# 521#############################################################################
429# old plug-in events 522# old plug-in events
… …
669 my ($map) = @_; 762 my ($map) = @_;
670 763
671 my $path = $map->tmpname; 764 my $path = $map->tmpname;
672 defined $path or return; 765 defined $path or return;
673 766
674 unlink "$path.cfperl";
675 unlink "$path.pst"; 767 unlink "$path.pst";
676}; 768};
677 769
770# old style persistent data, TODO: remove #d#
678*cf::mapsupport::on_swapin = 771*cf::mapsupport::on_swapin = sub {
679*cf::mapsupport::on_load = sub {
680 my ($map) = @_; 772 my ($map) = @_;
681 773
682 my $path = $map->tmpname; 774 my $path = $map->tmpname;
683 $path = $map->path unless defined $path; 775 $path = $map->path unless defined $path;
684 776
… …
689 781
690 $data->{version} <= 1 782 $data->{version} <= 1
691 or return; # too new 783 or return; # too new
692 784
693 $map->_set_obs ($data->{obs}); 785 $map->_set_obs ($data->{obs});
786 $map->invoke (EVENT_MAP_UPGRADE);
694}; 787};
695 788
696attach_to_maps prio => -10000, package => cf::mapsupport::; 789attach_to_maps prio => -10000, package => cf::mapsupport::;
697 790
698############################################################################# 791#############################################################################
… …
859 $TICK_WATCHER->at ($NEXT_TICK); 952 $TICK_WATCHER->at ($NEXT_TICK);
860 $TICK_WATCHER->start; 953 $TICK_WATCHER->start;
861 }, 954 },
862); 955);
863 956
957_reload_2;
958
8641 9591
865 960

Diff Legend

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