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.52 by root, Mon Aug 28 16:52:51 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
… …
169=item cf::attach_to_maps ... 173=item cf::attach_to_maps ...
170 174
171Attach handlers to all maps. 175Attach handlers to all maps.
172 176
173=item cf:register_attachment $name, ... 177=item cf:register_attachment $name, ...
178
179Register an attachment by name through which objects can refer to this
180attachment.
181
182=item cf:register_map_attachment $name, ...
183
184Register an attachment by name through which maps can refer to this
185attachment.
174 186
175=cut 187=cut
176 188
177# the following variables are defined in .xs and must not be re-created 189# the following variables are defined in .xs and must not be re-created
178our @CB_GLOBAL = (); # registry for all global events 190our @CB_GLOBAL = (); # registry for all global events
… …
241 253
242 \%undo 254 \%undo
243} 255}
244 256
245sub _attach_attachment { 257sub _attach_attachment {
246 my ($klass, $obj, $name, @args) = q_; 258 my ($obj, $name, %arg) = @_;
247 259
248 my $res; 260 my $res;
249 261
250 if (my $attach = $attachment{$name}) { 262 if (my $attach = $attachment{$name}) {
251 my $registry = $obj->registry; 263 my $registry = $obj->registry;
252 264
265 for (@$attach) {
266 my ($klass, @attach) = @$_;
253 $res = _attach @$registry, $klass, @$attach; 267 $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 } 268 }
269
270 $obj->{$name} = \%arg;
264 } else { 271 } else {
265 warn "object uses attachment '$name' that is not available, postponing.\n"; 272 warn "object uses attachment '$name' that is not available, postponing.\n";
266 } 273 }
267 274
268 push @{$obj->{_attachment}}, $name; 275 $obj->{_attachment}{$name} = undef;
269 276
270 $res->{attachment} = $name; 277 $res->{attachment} = $name;
271 $res 278 $res
272} 279}
273 280
274sub cf::object::attach { 281sub cf::object::attach {
275 my ($obj, $name, @args) = @_; 282 my ($obj, $name, %arg) = @_;
276 283
277 _attach_attachment KLASS_OBJECT, $obj, $name, @args; 284 _attach_attachment $obj, $name, %arg;
278} 285}
279 286
280sub cf::player::attach { 287sub cf::player::attach {
281 my ($obj, $name, @args) = @_; 288 my ($obj, $name, %arg) = @_;
282 289
283 _attach_attachment KLASS_PLAYER, $obj, $name, @args; 290 _attach_attachment $obj, $name, %arg;
284} 291}
285 292
286sub cf::map::attach { 293sub cf::map::attach {
287 my ($obj, $name, @args) = @_; 294 my ($obj, $name, %arg) = @_;
288 295
289 _attach_attachment KLASS_MAP, $obj, $name, @args; 296 _attach_attachment $obj, $name, %arg;
290} 297}
291 298
292sub attach_global { 299sub attach_global {
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
325 $attachment{$name} = [[KLASS_OBJECT, @_]];
326}
327
328sub register_map_attachment {
329 my $name = shift;
330
317 $attachment{$name} = [@_]; 331 $attachment{$name} = [[KLASS_MAP, @_]];
318} 332}
319 333
320our $override; 334our $override;
321our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 335our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
322 336
… …
356 370
357 $data = from_json $data; 371 $data = from_json $data;
358 372
359 for (@$data) { 373 for (@$data) {
360 my ($name, $args) = @$_; 374 my ($name, $args) = @$_;
361 attach $obj, $name, @{$args || [] }; 375
376 $obj->attach ($name, %{$args || {} });
362 } 377 }
363} 378}
364 379
365# basically do the same as instantiate, without calling instantiate 380# basically do the same as instantiate, without calling instantiate
366sub reattach { 381sub reattach {
367 warn "reattach<@_>\n";#d#
368 my ($obj) = @_; 382 my ($obj) = @_;
369 my $registry = $obj->registry; 383 my $registry = $obj->registry;
370 384
385 @$registry = ();
386
387 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
388
371 for my $name (@{ $obj->{_attachment} }) { 389 for my $name (keys %{ $obj->{_attachment} || {} }) {
372 if (my $attach = $attachment{$name}) { 390 if (my $attach = $attachment{$name}) {
391 for (@$attach) {
392 my ($klass, @attach) = @$_;
373 _attach @$registry, KLASS_OBJECT, @$attach; 393 _attach @$registry, $klass, @attach;
394 }
374 } else { 395 } else {
375 warn "object uses attachment '$name' that is not available, postponing.\n"; 396 warn "object uses attachment '$name' that is not available, postponing.\n";
376 } 397 }
377 } 398 }
378
379 warn "reattach<@_, $_>\n";
380} 399}
381 400
382sub object_freezer_save { 401sub object_freezer_save {
383 my ($filename, $objs) = @_; 402 my ($filename, $objs) = @_;
384 warn "freeze $filename\n";#d#
385 use Data::Dumper; print Dumper $objs;
386
387 $filename .= ".pst";
388 403
389 if (@$objs) { 404 if (@$objs) {
390 open my $fh, ">:raw", "$filename~"; 405 open my $fh, ">:raw", "$filename.pst~";
391 chmod $fh, SAVE_MODE;
392 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 406 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
393 close $fh; 407 close $fh;
408 chmod SAVE_MODE, "$filename.pst~";
394 rename "$filename~", $filename; 409 rename "$filename.pst~", "$filename.pst";
395 } else { 410 } else {
396 unlink $filename; 411 unlink "$filename.pst";
397 } 412 }
413
414 chmod SAVE_MODE, "$filename~";
415 rename "$filename~", $filename;
398} 416}
399 417
400sub object_thawer_load { 418sub object_thawer_load {
401 my ($filename) = @_; 419 my ($filename) = @_;
402
403 warn "thaw $filename\n";#d#
404 420
405 open my $fh, "<:raw:perlio", "$filename.pst" 421 open my $fh, "<:raw:perlio", "$filename.pst"
406 or return; 422 or return;
407 423
408 eval { local $/; (Storable::thaw <$fh>)->{objs} } 424 eval { local $/; (Storable::thaw <$fh>)->{objs} }
… …
412 prio => -1000000, 428 prio => -1000000,
413 on_clone => sub { 429 on_clone => sub {
414 my ($src, $dst) = @_; 430 my ($src, $dst) = @_;
415 431
416 @{$dst->registry} = @{$src->registry}; 432 @{$dst->registry} = @{$src->registry};
417 warn "registry clone ", join ":", @{$src->registry};#d#
418 433
419 %$dst = %$src; 434 %$dst = %$src;
420 435
421 $dst->{_attachment} = [@{ $src->{_attachment} }] 436 %{$dst->{_attachment}} = %{$src->{_attachment}}
422 if exists $src->{_attachment}; 437 if exists $src->{_attachment};
423
424 warn "clone<@_>\n";#d#
425 }, 438 },
426; 439;
427 440
428############################################################################# 441#############################################################################
429# old plug-in events 442# old plug-in events
… …
669 my ($map) = @_; 682 my ($map) = @_;
670 683
671 my $path = $map->tmpname; 684 my $path = $map->tmpname;
672 defined $path or return; 685 defined $path or return;
673 686
674 unlink "$path.cfperl";
675 unlink "$path.pst"; 687 unlink "$path.pst";
676}; 688};
677 689
690# old style persistent data, TODO: remove #d#
678*cf::mapsupport::on_swapin = 691*cf::mapsupport::on_swapin =
679*cf::mapsupport::on_load = sub { 692*cf::mapsupport::on_load = sub {
680 my ($map) = @_; 693 my ($map) = @_;
681 694
682 my $path = $map->tmpname; 695 my $path = $map->tmpname;
… …
689 702
690 $data->{version} <= 1 703 $data->{version} <= 1
691 or return; # too new 704 or return; # too new
692 705
693 $map->_set_obs ($data->{obs}); 706 $map->_set_obs ($data->{obs});
707 $map->invoke (EVENT_MAP_UPGRADE);
694}; 708};
695 709
696attach_to_maps prio => -10000, package => cf::mapsupport::; 710attach_to_maps prio => -10000, package => cf::mapsupport::;
697 711
698############################################################################# 712#############################################################################
… …
859 $TICK_WATCHER->at ($NEXT_TICK); 873 $TICK_WATCHER->at ($NEXT_TICK);
860 $TICK_WATCHER->start; 874 $TICK_WATCHER->start;
861 }, 875 },
862); 876);
863 877
878_reload_2;
879
8641 8801
865 881

Diff Legend

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