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.53 by root, Tue Aug 29 13:11:58 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 { 287sub cf::object::attach {
275 my ($obj, $name, @args) = @_; 288 my ($obj, $name, %arg) = @_;
276 289
277 _attach_attachment KLASS_OBJECT, $obj, $name, @args; 290 _attach_attachment $obj, $name, %arg;
278} 291}
279 292
280sub cf::player::attach { 293sub cf::player::attach {
281 my ($obj, $name, @args) = @_; 294 my ($obj, $name, %arg) = @_;
282 295
283 _attach_attachment KLASS_PLAYER, $obj, $name, @args; 296 _attach_attachment $obj, $name, %arg;
284} 297}
285 298
286sub cf::map::attach { 299sub cf::map::attach {
287 my ($obj, $name, @args) = @_; 300 my ($obj, $name, %arg) = @_;
288 301
289 _attach_attachment KLASS_MAP, $obj, $name, @args; 302 _attach_attachment $obj, $name, %arg;
303}
304
305sub cf::object::detach {
306 my ($obj, $name) = @_;
307 die;#d#
308}
309sub cf::player::detach {
310 my ($obj, $name) = @_;
311 die;#d#
312}
313sub cf::map::detach {
314 my ($obj, $name) = @_;
315 die;#d#
290} 316}
291 317
292sub attach_global { 318sub attach_global {
293 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 319 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
294} 320}
295 321
296sub attach_to_type { 322sub attach_to_type {
297 my $type = shift; 323 my $type = shift;
324 my $subtype = shift;
298 325
299 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_ 326 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
300} 327}
301 328
302sub attach_to_objects { 329sub attach_to_objects {
303 _attach @CB_OBJECT, KLASS_OBJECT, @_ 330 _attach @CB_OBJECT, KLASS_OBJECT, @_
304} 331}
… …
312} 339}
313 340
314sub register_attachment { 341sub register_attachment {
315 my $name = shift; 342 my $name = shift;
316 343
344 $attachment{$name} = [[KLASS_OBJECT, @_]];
345}
346
347sub register_map_attachment {
348 my $name = shift;
349
317 $attachment{$name} = [@_]; 350 $attachment{$name} = [[KLASS_MAP, @_]];
318} 351}
319 352
320our $override; 353our $override;
321our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 354our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
322 355
… …
356 389
357 $data = from_json $data; 390 $data = from_json $data;
358 391
359 for (@$data) { 392 for (@$data) {
360 my ($name, $args) = @$_; 393 my ($name, $args) = @$_;
361 attach $obj, $name, @{$args || [] }; 394
395 $obj->attach ($name, %{$args || {} });
362 } 396 }
363} 397}
364 398
365# basically do the same as instantiate, without calling instantiate 399# basically do the same as instantiate, without calling instantiate
366sub reattach { 400sub reattach {
367 warn "reattach<@_>\n";#d#
368 my ($obj) = @_; 401 my ($obj) = @_;
369 my $registry = $obj->registry; 402 my $registry = $obj->registry;
370 403
404 @$registry = ();
405
406 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
407
371 for my $name (@{ $obj->{_attachment} }) { 408 for my $name (keys %{ $obj->{_attachment} || {} }) {
372 if (my $attach = $attachment{$name}) { 409 if (my $attach = $attachment{$name}) {
410 for (@$attach) {
411 my ($klass, @attach) = @$_;
373 _attach @$registry, KLASS_OBJECT, @$attach; 412 _attach @$registry, $klass, @attach;
413 }
374 } else { 414 } else {
375 warn "object uses attachment '$name' that is not available, postponing.\n"; 415 warn "object uses attachment '$name' that is not available, postponing.\n";
376 } 416 }
377 } 417 }
378
379 warn "reattach<@_, $_>\n";
380} 418}
381 419
382sub object_freezer_save { 420sub object_freezer_save {
383 my ($filename, $objs) = @_; 421 my ($filename, $objs) = @_;
384 warn "freeze $filename\n";#d#
385 use Data::Dumper; print Dumper $objs;
386
387 $filename .= ".pst";
388 422
389 if (@$objs) { 423 if (@$objs) {
390 open my $fh, ">:raw", "$filename~"; 424 open my $fh, ">:raw", "$filename.pst~";
391 chmod $fh, SAVE_MODE;
392 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 425 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
393 close $fh; 426 close $fh;
427 chmod SAVE_MODE, "$filename.pst~";
394 rename "$filename~", $filename; 428 rename "$filename.pst~", "$filename.pst";
395 } else { 429 } else {
396 unlink $filename; 430 unlink "$filename.pst";
397 } 431 }
432
433 chmod SAVE_MODE, "$filename~";
434 rename "$filename~", $filename;
398} 435}
399 436
400sub object_thawer_load { 437sub object_thawer_load {
401 my ($filename) = @_; 438 my ($filename) = @_;
402
403 warn "thaw $filename\n";#d#
404 439
405 open my $fh, "<:raw:perlio", "$filename.pst" 440 open my $fh, "<:raw:perlio", "$filename.pst"
406 or return; 441 or return;
407 442
408 eval { local $/; (Storable::thaw <$fh>)->{objs} } 443 eval { local $/; (Storable::thaw <$fh>)->{objs} }
… …
412 prio => -1000000, 447 prio => -1000000,
413 on_clone => sub { 448 on_clone => sub {
414 my ($src, $dst) = @_; 449 my ($src, $dst) = @_;
415 450
416 @{$dst->registry} = @{$src->registry}; 451 @{$dst->registry} = @{$src->registry};
417 warn "registry clone ", join ":", @{$src->registry};#d#
418 452
419 %$dst = %$src; 453 %$dst = %$src;
420 454
421 $dst->{_attachment} = [@{ $src->{_attachment} }] 455 %{$dst->{_attachment}} = %{$src->{_attachment}}
422 if exists $src->{_attachment}; 456 if exists $src->{_attachment};
423
424 warn "clone<@_>\n";#d#
425 }, 457 },
426; 458;
427 459
428############################################################################# 460#############################################################################
429# old plug-in events 461# old plug-in events
… …
669 my ($map) = @_; 701 my ($map) = @_;
670 702
671 my $path = $map->tmpname; 703 my $path = $map->tmpname;
672 defined $path or return; 704 defined $path or return;
673 705
674 unlink "$path.cfperl";
675 unlink "$path.pst"; 706 unlink "$path.pst";
676}; 707};
677 708
709# old style persistent data, TODO: remove #d#
678*cf::mapsupport::on_swapin = 710*cf::mapsupport::on_swapin =
679*cf::mapsupport::on_load = sub { 711*cf::mapsupport::on_load = sub {
680 my ($map) = @_; 712 my ($map) = @_;
681 713
682 my $path = $map->tmpname; 714 my $path = $map->tmpname;
… …
689 721
690 $data->{version} <= 1 722 $data->{version} <= 1
691 or return; # too new 723 or return; # too new
692 724
693 $map->_set_obs ($data->{obs}); 725 $map->_set_obs ($data->{obs});
726 $map->invoke (EVENT_MAP_UPGRADE);
694}; 727};
695 728
696attach_to_maps prio => -10000, package => cf::mapsupport::; 729attach_to_maps prio => -10000, package => cf::mapsupport::;
697 730
698############################################################################# 731#############################################################################
… …
859 $TICK_WATCHER->at ($NEXT_TICK); 892 $TICK_WATCHER->at ($NEXT_TICK);
860 $TICK_WATCHER->start; 893 $TICK_WATCHER->start;
861 }, 894 },
862); 895);
863 896
897_reload_2;
898
8641 8991
865 900

Diff Legend

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