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.54 by root, Tue Aug 29 14:49:28 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=item $object->attach ($attachment, key => $value...)
111
108=item $object->attach ($attachment, ...) 112=item $object->detach ($attachment)
109 113
110Attach a pre-registered attachment to an object. 114Attach/detach a pre-registered attachment to an object.
111 115
116=item $player->attach ($attachment, key => $value...)
117
112=item $player->attach ($attachment, ...) 118=item $player->detach ($attachment)
113 119
114Attach a pre-registered attachment to a player. 120Attach/detach a pre-registered attachment to a player.
115 121
116=item $map->attach ($attachment, ...) # not yet persistent 122=item $map->attach ($attachment, key => $value...)
117 123
124=item $map->detach ($attachment)
125
118Attach a pre-registered attachment to a map. 126Attach/detach a pre-registered attachment to a map.
119 127
120=item cf::attach_global ... 128=item cf::attach_global ...
121 129
122Attach handlers for global events. 130Attach handlers for global events.
123 131
… …
150package and register them. Only handlers for eevents supported by the 158package and register them. Only handlers for eevents supported by the
151object/class are recognised. 159object/class are recognised.
152 160
153=back 161=back
154 162
155=item cf::attach_to_type $object_type, ... 163=item cf::attach_to_type $object_type, $subtype, ...
156 164
157Attach handlers for a specific object type (e.g. TRANSPORT). 165Attach handlers for a specific object type (e.g. TRANSPORT) and
166subtype. If C<$subtype> is zero or undef, matches all objects of the given
167type.
158 168
159=item cf::attach_to_objects ... 169=item cf::attach_to_objects ...
160 170
161Attach handlers to all objects. Do not use this except for debugging or 171Attach 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 172very rare events, as handlers are (obviously) called for I<all> objects in
… …
169=item cf::attach_to_maps ... 179=item cf::attach_to_maps ...
170 180
171Attach handlers to all maps. 181Attach handlers to all maps.
172 182
173=item cf:register_attachment $name, ... 183=item cf:register_attachment $name, ...
184
185Register an attachment by name through which objects can refer to this
186attachment.
187
188=item cf:register_map_attachment $name, ...
189
190Register an attachment by name through which maps can refer to this
191attachment.
174 192
175=cut 193=cut
176 194
177# the following variables are defined in .xs and must not be re-created 195# the following variables are defined in .xs and must not be re-created
178our @CB_GLOBAL = (); # registry for all global events 196our @CB_GLOBAL = (); # registry for all global events
… …
241 259
242 \%undo 260 \%undo
243} 261}
244 262
245sub _attach_attachment { 263sub _attach_attachment {
246 my ($klass, $obj, $name, @args) = q_; 264 my ($obj, $name, %arg) = @_;
247 265
248 my $res; 266 my $res;
249 267
250 if (my $attach = $attachment{$name}) { 268 if (my $attach = $attachment{$name}) {
251 my $registry = $obj->registry; 269 my $registry = $obj->registry;
252 270
271 for (@$attach) {
272 my ($klass, @attach) = @$_;
253 $res = _attach @$registry, $klass, @$attach; 273 $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 } 274 }
275
276 $obj->{$name} = \%arg;
264 } else { 277 } else {
265 warn "object uses attachment '$name' that is not available, postponing.\n"; 278 warn "object uses attachment '$name' that is not available, postponing.\n";
266 } 279 }
267 280
268 push @{$obj->{_attachment}}, $name; 281 $obj->{_attachment}{$name} = undef;
269 282
270 $res->{attachment} = $name; 283 $res->{attachment} = $name;
271 $res 284 $res
272} 285}
273 286
274sub cf::object::attach { 287*cf::object::attach =
288*cf::player::attach =
289*cf::map::attach = sub {
275 my ($obj, $name, @args) = @_; 290 my ($obj, $name, %arg) = @_;
276 291
277 _attach_attachment KLASS_OBJECT, $obj, $name, @args; 292 _attach_attachment $obj, $name, %arg;
278} 293}
279 294
295# all those should be optimised
296*cf::object::detach =
280sub cf::player::attach { 297*cf::player::detach =
298*cf::map::detach = sub {
281 my ($obj, $name, @args) = @_; 299 my ($obj, $name) = @_;
282 300
283 _attach_attachment KLASS_PLAYER, $obj, $name, @args; 301 delete $obj->{_attachment}{$name};
284} 302 reattach $obj;
285 303};
286sub cf::map::attach {
287 my ($obj, $name, @args) = @_;
288
289 _attach_attachment KLASS_MAP, $obj, $name, @args;
290}
291 304
292sub attach_global { 305sub attach_global {
293 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 306 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
294} 307}
295 308
296sub attach_to_type { 309sub attach_to_type {
297 my $type = shift; 310 my $type = shift;
311 my $subtype = shift;
298 312
299 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_ 313 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
300} 314}
301 315
302sub attach_to_objects { 316sub attach_to_objects {
303 _attach @CB_OBJECT, KLASS_OBJECT, @_ 317 _attach @CB_OBJECT, KLASS_OBJECT, @_
304} 318}
… …
312} 326}
313 327
314sub register_attachment { 328sub register_attachment {
315 my $name = shift; 329 my $name = shift;
316 330
331 $attachment{$name} = [[KLASS_OBJECT, @_]];
332}
333
334sub register_map_attachment {
335 my $name = shift;
336
317 $attachment{$name} = [@_]; 337 $attachment{$name} = [[KLASS_MAP, @_]];
318} 338}
319 339
320our $override; 340our $override;
321our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 341our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
322 342
… …
356 376
357 $data = from_json $data; 377 $data = from_json $data;
358 378
359 for (@$data) { 379 for (@$data) {
360 my ($name, $args) = @$_; 380 my ($name, $args) = @$_;
361 attach $obj, $name, @{$args || [] }; 381
382 $obj->attach ($name, %{$args || {} });
362 } 383 }
363} 384}
364 385
365# basically do the same as instantiate, without calling instantiate 386# basically do the same as instantiate, without calling instantiate
366sub reattach { 387sub reattach {
367 warn "reattach<@_>\n";#d#
368 my ($obj) = @_; 388 my ($obj) = @_;
369 my $registry = $obj->registry; 389 my $registry = $obj->registry;
370 390
391 @$registry = ();
392
393 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
394
371 for my $name (@{ $obj->{_attachment} }) { 395 for my $name (keys %{ $obj->{_attachment} || {} }) {
372 if (my $attach = $attachment{$name}) { 396 if (my $attach = $attachment{$name}) {
397 for (@$attach) {
398 my ($klass, @attach) = @$_;
373 _attach @$registry, KLASS_OBJECT, @$attach; 399 _attach @$registry, $klass, @attach;
400 }
374 } else { 401 } else {
375 warn "object uses attachment '$name' that is not available, postponing.\n"; 402 warn "object uses attachment '$name' that is not available, postponing.\n";
376 } 403 }
377 } 404 }
378
379 warn "reattach<@_, $_>\n";
380} 405}
381 406
382sub object_freezer_save { 407sub object_freezer_save {
383 my ($filename, $objs) = @_; 408 my ($filename, $objs) = @_;
384 warn "freeze $filename\n";#d#
385 use Data::Dumper; print Dumper $objs;
386
387 $filename .= ".pst";
388 409
389 if (@$objs) { 410 if (@$objs) {
390 open my $fh, ">:raw", "$filename~"; 411 open my $fh, ">:raw", "$filename.pst~";
391 chmod $fh, SAVE_MODE;
392 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 412 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
393 close $fh; 413 close $fh;
414 chmod SAVE_MODE, "$filename.pst~";
394 rename "$filename~", $filename; 415 rename "$filename.pst~", "$filename.pst";
395 } else { 416 } else {
396 unlink $filename; 417 unlink "$filename.pst";
397 } 418 }
419
420 chmod SAVE_MODE, "$filename~";
421 rename "$filename~", $filename;
398} 422}
399 423
400sub object_thawer_load { 424sub object_thawer_load {
401 my ($filename) = @_; 425 my ($filename) = @_;
402
403 warn "thaw $filename\n";#d#
404 426
405 open my $fh, "<:raw:perlio", "$filename.pst" 427 open my $fh, "<:raw:perlio", "$filename.pst"
406 or return; 428 or return;
407 429
408 eval { local $/; (Storable::thaw <$fh>)->{objs} } 430 eval { local $/; (Storable::thaw <$fh>)->{objs} }
… …
412 prio => -1000000, 434 prio => -1000000,
413 on_clone => sub { 435 on_clone => sub {
414 my ($src, $dst) = @_; 436 my ($src, $dst) = @_;
415 437
416 @{$dst->registry} = @{$src->registry}; 438 @{$dst->registry} = @{$src->registry};
417 warn "registry clone ", join ":", @{$src->registry};#d#
418 439
419 %$dst = %$src; 440 %$dst = %$src;
420 441
421 $dst->{_attachment} = [@{ $src->{_attachment} }] 442 %{$dst->{_attachment}} = %{$src->{_attachment}}
422 if exists $src->{_attachment}; 443 if exists $src->{_attachment};
423
424 warn "clone<@_>\n";#d#
425 }, 444 },
426; 445;
427 446
428############################################################################# 447#############################################################################
429# old plug-in events 448# old plug-in events
… …
669 my ($map) = @_; 688 my ($map) = @_;
670 689
671 my $path = $map->tmpname; 690 my $path = $map->tmpname;
672 defined $path or return; 691 defined $path or return;
673 692
674 unlink "$path.cfperl";
675 unlink "$path.pst"; 693 unlink "$path.pst";
676}; 694};
677 695
696# old style persistent data, TODO: remove #d#
678*cf::mapsupport::on_swapin = 697*cf::mapsupport::on_swapin =
679*cf::mapsupport::on_load = sub { 698*cf::mapsupport::on_load = sub {
680 my ($map) = @_; 699 my ($map) = @_;
681 700
682 my $path = $map->tmpname; 701 my $path = $map->tmpname;
… …
689 708
690 $data->{version} <= 1 709 $data->{version} <= 1
691 or return; # too new 710 or return; # too new
692 711
693 $map->_set_obs ($data->{obs}); 712 $map->_set_obs ($data->{obs});
713 $map->invoke (EVENT_MAP_UPGRADE);
694}; 714};
695 715
696attach_to_maps prio => -10000, package => cf::mapsupport::; 716attach_to_maps prio => -10000, package => cf::mapsupport::;
697 717
698############################################################################# 718#############################################################################
… …
859 $TICK_WATCHER->at ($NEXT_TICK); 879 $TICK_WATCHER->at ($NEXT_TICK);
860 $TICK_WATCHER->start; 880 $TICK_WATCHER->start;
861 }, 881 },
862); 882);
863 883
884_reload_2;
885
8641 8861
865 887

Diff Legend

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