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.47 by root, Sun Aug 27 13:02:04 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";
… …
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, @args) = @_;
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;
260 }
254 261
255 if (my $cb = delete $registry->[EVENT_OBJECT_INSTANTIATE]) { 262 if (my $cb = delete $registry->[EVENT_OBJECT_INSTANTIATE]) {
256 for (@$cb) { 263 for (@$cb) {
257 eval { $_->[1]->($obj, @args); }; 264 eval { $_->[1]->($obj, @args); };
258 if ($@) { 265 if ($@) {
… …
272} 279}
273 280
274sub cf::object::attach { 281sub cf::object::attach {
275 my ($obj, $name, @args) = @_; 282 my ($obj, $name, @args) = @_;
276 283
277 _attach_attachment KLASS_OBJECT, $obj, $name, @args; 284 _attach_attachment $obj, $name, @args;
278} 285}
279 286
280sub cf::player::attach { 287sub cf::player::attach {
281 my ($obj, $name, @args) = @_; 288 my ($obj, $name, @args) = @_;
282 289
… …
293 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 300 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
294} 301}
295 302
296sub attach_to_type { 303sub attach_to_type {
297 my $type = shift; 304 my $type = shift;
305 my $subtype = shift;
298 306
299 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_ 307 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
300} 308}
301 309
302sub attach_to_objects { 310sub attach_to_objects {
303 _attach @CB_OBJECT, KLASS_OBJECT, @_ 311 _attach @CB_OBJECT, KLASS_OBJECT, @_
304} 312}
… …
312} 320}
313 321
314sub register_attachment { 322sub register_attachment {
315 my $name = shift; 323 my $name = shift;
316 324
317 $attachment{$name} = [@_]; 325 $attachment{$name} = [[KLASS_OBJECT, @_]];
318} 326}
319 327
320our $override; 328our $override;
321our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 329our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
322 330
… …
362 } 370 }
363} 371}
364 372
365# basically do the same as instantiate, without calling instantiate 373# basically do the same as instantiate, without calling instantiate
366sub reattach { 374sub reattach {
367 warn "reattach<@_>\n";#d#
368 my ($obj) = @_; 375 my ($obj) = @_;
369 my $registry = $obj->registry; 376 my $registry = $obj->registry;
370 377
378 @$registry = ();
379
371 for my $name (@{ $obj->{_attachment} }) { 380 for my $name (@{ $obj->{_attachment} }) {
372 if (my $attach = $attachment{$name}) { 381 if (my $attach = $attachment{$name}) {
382 for (@$attach) {
383 my ($klass, @attach) = @$_;
373 _attach @$registry, KLASS_OBJECT, @$attach; 384 _attach @$registry, $klass, @attach;
385 }
374 } else { 386 } else {
375 warn "object uses attachment '$name' that is not available, postponing.\n"; 387 warn "object uses attachment '$name' that is not available, postponing.\n";
376 } 388 }
377 } 389 }
378
379 warn "reattach<@_, $_>\n";
380} 390}
381 391
382sub object_freezer_save { 392sub object_freezer_save {
383 my ($filename, $objs) = @_; 393 my ($filename, $objs) = @_;
384 warn "freeze $filename\n";#d#
385 use Data::Dumper; print Dumper $objs;
386 394
387 $filename .= ".pst"; 395 $filename .= ".pst";
388 396
389 if (@$objs) { 397 if (@$objs) {
390 open my $fh, ">:raw", "$filename~"; 398 open my $fh, ">:raw", "$filename~";
… …
398} 406}
399 407
400sub object_thawer_load { 408sub object_thawer_load {
401 my ($filename) = @_; 409 my ($filename) = @_;
402 410
403 warn "thaw $filename\n";#d#
404
405 open my $fh, "<:raw:perlio", "$filename.pst" 411 open my $fh, "<:raw:perlio", "$filename.pst"
406 or return; 412 or return;
407 413
408 eval { local $/; (Storable::thaw <$fh>)->{objs} } 414 eval { local $/; (Storable::thaw <$fh>)->{objs} }
409} 415}
… …
412 prio => -1000000, 418 prio => -1000000,
413 on_clone => sub { 419 on_clone => sub {
414 my ($src, $dst) = @_; 420 my ($src, $dst) = @_;
415 421
416 @{$dst->registry} = @{$src->registry}; 422 @{$dst->registry} = @{$src->registry};
417 warn "registry clone ", join ":", @{$src->registry};#d#
418 423
419 %$dst = %$src; 424 %$dst = %$src;
420 425
421 $dst->{_attachment} = [@{ $src->{_attachment} }] 426 $dst->{_attachment} = [@{ $src->{_attachment} }]
422 if exists $src->{_attachment}; 427 if exists $src->{_attachment};
423
424 warn "clone<@_>\n";#d#
425 }, 428 },
426; 429;
427 430
428############################################################################# 431#############################################################################
429# old plug-in events 432# old plug-in events
… …
859 $TICK_WATCHER->at ($NEXT_TICK); 862 $TICK_WATCHER->at ($NEXT_TICK);
860 $TICK_WATCHER->start; 863 $TICK_WATCHER->start;
861 }, 864 },
862); 865);
863 866
867_reload_2;
868
8641 8691
865 870

Diff Legend

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