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.51 by root, Mon Aug 28 14:05: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
108=item $object->attach ($attachment, ...) 110=item $object->attach ($attachment, key => $value...)
109 111
110Attach a pre-registered attachment to an object. 112Attach a pre-registered attachment to an object.
111 113
112=item $player->attach ($attachment, ...) 114=item $player->attach ($attachment, key => $value...)
113 115
114Attach a pre-registered attachment to a player. 116Attach a pre-registered attachment to a player.
115 117
116=item $map->attach ($attachment, ...) # not yet persistent 118=item $map->attach ($attachment, key => $value...) # not yet persistent
117 119
118Attach a pre-registered attachment to a map. 120Attach a pre-registered attachment to a map.
119 121
120=item cf::attach_global ... 122=item cf::attach_global ...
121 123
… …
150package and register them. Only handlers for eevents supported by the 152package and register them. Only handlers for eevents supported by the
151object/class are recognised. 153object/class are recognised.
152 154
153=back 155=back
154 156
155=item cf::attach_to_type $object_type, ... 157=item cf::attach_to_type $object_type, $subtype, ...
156 158
157Attach handlers for a specific object type (e.g. TRANSPORT). 159Attach handlers for a specific object type (e.g. TRANSPORT) and
160subtype. If C<$subtype> is zero or undef, matches all objects of the given
161type.
158 162
159=item cf::attach_to_objects ... 163=item cf::attach_to_objects ...
160 164
161Attach handlers to all objects. Do not use this except for debugging or 165Attach 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 166very rare events, as handlers are (obviously) called for I<all> objects in
… …
241 245
242 \%undo 246 \%undo
243} 247}
244 248
245sub _attach_attachment { 249sub _attach_attachment {
246 my ($klass, $obj, $name, @args) = q_; 250 my ($obj, $name, %arg) = @_;
247 251
248 my $res; 252 my $res;
249 253
250 if (my $attach = $attachment{$name}) { 254 if (my $attach = $attachment{$name}) {
251 my $registry = $obj->registry; 255 my $registry = $obj->registry;
252 256
257 for (@$attach) {
258 my ($klass, @attach) = @$_;
253 $res = _attach @$registry, $klass, @$attach; 259 $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 } 260 }
261
262 $obj->{$name} = \%arg;
264 } else { 263 } else {
265 warn "object uses attachment '$name' that is not available, postponing.\n"; 264 warn "object uses attachment '$name' that is not available, postponing.\n";
266 } 265 }
267 266
268 push @{$obj->{_attachment}}, $name; 267 $obj->{_attachment}{$name} = undef;
269 268
270 $res->{attachment} = $name; 269 $res->{attachment} = $name;
271 $res 270 $res
272} 271}
273 272
274sub cf::object::attach { 273sub cf::object::attach {
275 my ($obj, $name, @args) = @_; 274 my ($obj, $name, %arg) = @_;
276 275
277 _attach_attachment KLASS_OBJECT, $obj, $name, @args; 276 _attach_attachment $obj, $name, %arg;
278} 277}
279 278
280sub cf::player::attach { 279sub cf::player::attach {
281 my ($obj, $name, @args) = @_; 280 my ($obj, $name, %arg) = @_;
282 281
283 _attach_attachment KLASS_PLAYER, $obj, $name, @args; 282 _attach_attachment KLASS_PLAYER, $obj, $name, %arg;
284} 283}
285 284
286sub cf::map::attach { 285sub cf::map::attach {
287 my ($obj, $name, @args) = @_; 286 my ($obj, $name, %arg) = @_;
288 287
289 _attach_attachment KLASS_MAP, $obj, $name, @args; 288 _attach_attachment KLASS_MAP, $obj, $name, %arg;
290} 289}
291 290
292sub attach_global { 291sub attach_global {
293 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 292 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
294} 293}
295 294
296sub attach_to_type { 295sub attach_to_type {
297 my $type = shift; 296 my $type = shift;
297 my $subtype = shift;
298 298
299 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_ 299 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
300} 300}
301 301
302sub attach_to_objects { 302sub attach_to_objects {
303 _attach @CB_OBJECT, KLASS_OBJECT, @_ 303 _attach @CB_OBJECT, KLASS_OBJECT, @_
304} 304}
… …
312} 312}
313 313
314sub register_attachment { 314sub register_attachment {
315 my $name = shift; 315 my $name = shift;
316 316
317 $attachment{$name} = [@_]; 317 $attachment{$name} = [[KLASS_OBJECT, @_]];
318} 318}
319 319
320our $override; 320our $override;
321our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 321our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
322 322
… …
356 356
357 $data = from_json $data; 357 $data = from_json $data;
358 358
359 for (@$data) { 359 for (@$data) {
360 my ($name, $args) = @$_; 360 my ($name, $args) = @$_;
361 attach $obj, $name, @{$args || [] }; 361
362 $obj->attach ($name, %{$args || {} });
362 } 363 }
363} 364}
364 365
365# basically do the same as instantiate, without calling instantiate 366# basically do the same as instantiate, without calling instantiate
366sub reattach { 367sub reattach {
367 warn "reattach<@_>\n";#d#
368 my ($obj) = @_; 368 my ($obj) = @_;
369 my $registry = $obj->registry; 369 my $registry = $obj->registry;
370 370
371 @$registry = ();
372
373 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
374
371 for my $name (@{ $obj->{_attachment} }) { 375 for my $name (keys %{ $obj->{_attachment} || {} }) {
372 if (my $attach = $attachment{$name}) { 376 if (my $attach = $attachment{$name}) {
377 for (@$attach) {
378 my ($klass, @attach) = @$_;
373 _attach @$registry, KLASS_OBJECT, @$attach; 379 _attach @$registry, $klass, @attach;
380 }
374 } else { 381 } else {
375 warn "object uses attachment '$name' that is not available, postponing.\n"; 382 warn "object uses attachment '$name' that is not available, postponing.\n";
376 } 383 }
377 } 384 }
378
379 warn "reattach<@_, $_>\n";
380} 385}
381 386
382sub object_freezer_save { 387sub object_freezer_save {
383 my ($filename, $objs) = @_; 388 my ($filename, $objs) = @_;
384 warn "freeze $filename\n";#d#
385 use Data::Dumper; print Dumper $objs;
386
387 $filename .= ".pst";
388 389
389 if (@$objs) { 390 if (@$objs) {
390 open my $fh, ">:raw", "$filename~"; 391 open my $fh, ">:raw", "$filename.pst~";
391 chmod $fh, SAVE_MODE;
392 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 392 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
393 close $fh; 393 close $fh;
394 chmod SAVE_MODE, "$filename.pst~";
394 rename "$filename~", $filename; 395 rename "$filename.pst~", "$filename.pst";
395 } else { 396 } else {
396 unlink $filename; 397 unlink "$filename.pst";
397 } 398 }
399
400 chmod SAVE_MODE, "$filename~";
401 rename "$filename~", $filename;
398} 402}
399 403
400sub object_thawer_load { 404sub object_thawer_load {
401 my ($filename) = @_; 405 my ($filename) = @_;
402
403 warn "thaw $filename\n";#d#
404 406
405 open my $fh, "<:raw:perlio", "$filename.pst" 407 open my $fh, "<:raw:perlio", "$filename.pst"
406 or return; 408 or return;
407 409
408 eval { local $/; (Storable::thaw <$fh>)->{objs} } 410 eval { local $/; (Storable::thaw <$fh>)->{objs} }
… …
412 prio => -1000000, 414 prio => -1000000,
413 on_clone => sub { 415 on_clone => sub {
414 my ($src, $dst) = @_; 416 my ($src, $dst) = @_;
415 417
416 @{$dst->registry} = @{$src->registry}; 418 @{$dst->registry} = @{$src->registry};
417 warn "registry clone ", join ":", @{$src->registry};#d#
418 419
419 %$dst = %$src; 420 %$dst = %$src;
420 421
421 $dst->{_attachment} = [@{ $src->{_attachment} }] 422 %{$dst->{_attachment}} = %{$src->{_attachment}}
422 if exists $src->{_attachment}; 423 if exists $src->{_attachment};
423
424 warn "clone<@_>\n";#d#
425 }, 424 },
426; 425;
427 426
428############################################################################# 427#############################################################################
429# old plug-in events 428# old plug-in events
… …
669 my ($map) = @_; 668 my ($map) = @_;
670 669
671 my $path = $map->tmpname; 670 my $path = $map->tmpname;
672 defined $path or return; 671 defined $path or return;
673 672
674 unlink "$path.cfperl";
675 unlink "$path.pst"; 673 unlink "$path.pst";
676}; 674};
677 675
676# old style persistent data, TODO: remove #d#
678*cf::mapsupport::on_swapin = 677*cf::mapsupport::on_swapin =
679*cf::mapsupport::on_load = sub { 678*cf::mapsupport::on_load = sub {
680 my ($map) = @_; 679 my ($map) = @_;
681 680
682 my $path = $map->tmpname; 681 my $path = $map->tmpname;
… …
689 688
690 $data->{version} <= 1 689 $data->{version} <= 1
691 or return; # too new 690 or return; # too new
692 691
693 $map->_set_obs ($data->{obs}); 692 $map->_set_obs ($data->{obs});
693 $map->invoke (EVENT_MAP_UPGRADE);
694}; 694};
695 695
696attach_to_maps prio => -10000, package => cf::mapsupport::; 696attach_to_maps prio => -10000, package => cf::mapsupport::;
697 697
698############################################################################# 698#############################################################################
… …
859 $TICK_WATCHER->at ($NEXT_TICK); 859 $TICK_WATCHER->at ($NEXT_TICK);
860 $TICK_WATCHER->start; 860 $TICK_WATCHER->start;
861 }, 861 },
862); 862);
863 863
864_reload_2;
865
8641 8661
865 867

Diff Legend

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