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.45 by root, Sat Aug 26 23:36:32 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 cf::object::attach ... # NYI 110=item $object->attach ($attachment, key => $value...)
111
112Attach a pre-registered attachment to an object.
113
114=item $player->attach ($attachment, key => $value...)
115
116Attach a pre-registered attachment to a player.
117
118=item $map->attach ($attachment, key => $value...) # not yet persistent
119
120Attach a pre-registered attachment to a map.
109 121
110=item cf::attach_global ... 122=item cf::attach_global ...
111 123
124Attach handlers for global events.
125
126This and all following C<attach_*>-functions expect any number of the
127following handler/hook descriptions:
128
129=over 4
130
131=item prio => $number
132
133Set the priority for all following handlers/hooks (unless overwritten
134by another C<prio> setting). Lower priority handlers get executed
135earlier. The default priority is C<0>, and many built-in handlers are
136registered at priority C<-1000>, so lower priorities should not be used
137unless you know what you are doing.
138
139=item on_I<event> => \&cb
140
141Call the given code reference whenever the named event happens (event is
142something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
143handlers are recognised generally depends on the type of object these
144handlers attach to).
145
146See F<include/eventinc.h> for the full list of events supported, and their
147class.
148
149=item package => package::
150
151Look for sub functions of the name C<< on_I<event> >> in the given
152package and register them. Only handlers for eevents supported by the
153object/class are recognised.
154
155=back
156
112=item cf::attach_to_type $object_type, ... 157=item cf::attach_to_type $object_type, $subtype, ...
158
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.
113 162
114=item cf::attach_to_objects ... 163=item cf::attach_to_objects ...
115 164
165Attach handlers to all objects. Do not use this except for debugging or
166very rare events, as handlers are (obviously) called for I<all> objects in
167the game.
168
116=item cf::attach_to_players ... 169=item cf::attach_to_players ...
117 170
171Attach handlers to all players.
172
118=item cf::attach_to_maps ... 173=item cf::attach_to_maps ...
119 174
175Attach handlers to all maps.
176
120=item cf:register_attachment $name, ... 177=item cf:register_attachment $name, ...
121
122 prio => $number, # lower is earlier
123 on_xxx => \&cb,
124 package => package::,
125 178
126=cut 179=cut
127 180
128# the following variables are defined in .xs and must not be re-created 181# the following variables are defined in .xs and must not be re-created
129our @CB_GLOBAL = (); # registry for all global events 182our @CB_GLOBAL = (); # registry for all global events
… …
191 } 244 }
192 245
193 \%undo 246 \%undo
194} 247}
195 248
249sub _attach_attachment {
250 my ($obj, $name, %arg) = @_;
251
252 my $res;
253
254 if (my $attach = $attachment{$name}) {
255 my $registry = $obj->registry;
256
257 for (@$attach) {
258 my ($klass, @attach) = @$_;
259 $res = _attach @$registry, $klass, @attach;
260 }
261
262 $obj->{$name} = \%arg;
263 } else {
264 warn "object uses attachment '$name' that is not available, postponing.\n";
265 }
266
267 $obj->{_attachment}{$name} = undef;
268
269 $res->{attachment} = $name;
270 $res
271}
272
196sub cf::object::attach { 273sub cf::object::attach {
197 die; 274 my ($obj, $name, %arg) = @_;
275
276 _attach_attachment $obj, $name, %arg;
277}
278
279sub cf::player::attach {
280 my ($obj, $name, %arg) = @_;
281
282 _attach_attachment KLASS_PLAYER, $obj, $name, %arg;
283}
284
285sub cf::map::attach {
286 my ($obj, $name, %arg) = @_;
287
288 _attach_attachment KLASS_MAP, $obj, $name, %arg;
198} 289}
199 290
200sub attach_global { 291sub attach_global {
201 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 292 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
202} 293}
203 294
204sub attach_to_type { 295sub attach_to_type {
205 my $type = shift; 296 my $type = shift;
297 my $subtype = shift;
206 298
207 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_ 299 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
208} 300}
209 301
210sub attach_to_objects { 302sub attach_to_objects {
211 _attach @CB_OBJECT, KLASS_OBJECT, @_ 303 _attach @CB_OBJECT, KLASS_OBJECT, @_
212} 304}
… …
220} 312}
221 313
222sub register_attachment { 314sub register_attachment {
223 my $name = shift; 315 my $name = shift;
224 316
225 $attachment{$name} = [@_]; 317 $attachment{$name} = [[KLASS_OBJECT, @_]];
226} 318}
227 319
228our $override; 320our $override;
229our @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?
230 322
… …
259############################################################################# 351#############################################################################
260# object support 352# object support
261 353
262sub instantiate { 354sub instantiate {
263 my ($obj, $data) = @_; 355 my ($obj, $data) = @_;
264 my $registry = $obj->registry;
265 356
266 $data = from_json $data; 357 $data = from_json $data;
267 358
268 for (@$data) { 359 for (@$data) {
269 my ($pri, $name, @args) = @$_; 360 my ($name, $args) = @$_;
270 361
271 if (my $attach = $attachment{$name}) { 362 $obj->attach ($name, %{$args || {} });
272 _attach @$registry, KLASS_OBJECT, @$attach;
273
274 if (my $cb = delete $registry->[EVENT_OBJECT_INSTANTIATE]) {
275 for (@$cb) {
276 eval { $_->[1]->($obj, @args); };
277 if ($@) {
278 warn "$@";
279 warn "... while processing '$name' instantiate with args <@args>\n";
280 }
281 }
282 }
283 } else {
284 warn "object uses attachment $name that is not available, postponing.\n";
285 }
286
287 push @{$obj->{_attachment}}, $name;
288 } 363 }
289} 364}
290 365
291# basically do the same as instantiate, without calling instantiate 366# basically do the same as instantiate, without calling instantiate
292sub reattach { 367sub reattach {
293 my ($obj) = @_; 368 my ($obj) = @_;
294 my $registry = $obj->registry; 369 my $registry = $obj->registry;
295 370
296 warn "reattach<@_, $_>\n"; 371 @$registry = ();
372
373 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
374
375 for my $name (keys %{ $obj->{_attachment} || {} }) {
376 if (my $attach = $attachment{$name}) {
377 for (@$attach) {
378 my ($klass, @attach) = @$_;
379 _attach @$registry, $klass, @attach;
380 }
381 } else {
382 warn "object uses attachment '$name' that is not available, postponing.\n";
383 }
384 }
385}
386
387sub object_freezer_save {
388 my ($filename, $objs) = @_;
389
390 if (@$objs) {
391 open my $fh, ">:raw", "$filename.pst~";
392 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
393 close $fh;
394 chmod SAVE_MODE, "$filename.pst~";
395 rename "$filename.pst~", "$filename.pst";
396 } else {
397 unlink "$filename.pst";
398 }
399
400 chmod SAVE_MODE, "$filename~";
401 rename "$filename~", $filename;
402}
403
404sub object_thawer_load {
405 my ($filename) = @_;
406
407 open my $fh, "<:raw:perlio", "$filename.pst"
408 or return;
409
410 eval { local $/; (Storable::thaw <$fh>)->{objs} }
297} 411}
298 412
299attach_to_objects 413attach_to_objects
300 prio => -1000000, 414 prio => -1000000,
301 on_clone => sub { 415 on_clone => sub {
302 my ($src, $dst) = @_; 416 my ($src, $dst) = @_;
303 417
304 @{$dst->registry} = @{$src->registry}; 418 @{$dst->registry} = @{$src->registry};
305 warn "registry clone ", join ":", @{$src->registry};#d#
306 419
307 %$dst = %$src; 420 %$dst = %$src;
308 421
309 $dst->{_attachment} = [@{ $src->{_attachment} }] 422 %{$dst->{_attachment}} = %{$src->{_attachment}}
310 if exists $src->{_attachment}; 423 if exists $src->{_attachment};
311
312 warn "clone<@_>\n";#d#
313 }, 424 },
314; 425;
315 426
316############################################################################# 427#############################################################################
317# old plug-in events 428# old plug-in events
… …
557 my ($map) = @_; 668 my ($map) = @_;
558 669
559 my $path = $map->tmpname; 670 my $path = $map->tmpname;
560 defined $path or return; 671 defined $path or return;
561 672
562 unlink "$path.cfperl"; 673 unlink "$path.pst";
563}; 674};
564 675
676# old style persistent data, TODO: remove #d#
565*cf::mapsupport::on_swapin = 677*cf::mapsupport::on_swapin =
566*cf::mapsupport::on_load = sub { 678*cf::mapsupport::on_load = sub {
567 my ($map) = @_; 679 my ($map) = @_;
568 680
569 my $path = $map->tmpname; 681 my $path = $map->tmpname;
… …
576 688
577 $data->{version} <= 1 689 $data->{version} <= 1
578 or return; # too new 690 or return; # too new
579 691
580 $map->_set_obs ($data->{obs}); 692 $map->_set_obs ($data->{obs});
581}; 693 $map->invoke (EVENT_MAP_UPGRADE);
582
583*cf::mapsupport::on_swapout = sub {
584 my ($map) = @_;
585
586 my $path = $map->tmpname;
587 $path = $map->path unless defined $path;
588
589 my $obs = $map->_get_obs;
590
591 if (defined $obs) {
592 open my $fh, ">:raw", "$path.cfperl"
593 or die "$path.cfperl: $!";
594
595 stat $path;
596
597 print $fh Storable::nfreeze {
598 size => (stat _)[7],
599 time => (stat _)[9],
600 version => 1,
601 obs => $obs,
602 };
603
604 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
605 } else {
606 unlink "$path.cfperl";
607 }
608}; 694};
609 695
610attach_to_maps prio => -10000, package => cf::mapsupport::; 696attach_to_maps prio => -10000, package => cf::mapsupport::;
611 697
612############################################################################# 698#############################################################################
… …
625 $o->set_ob_key_value ("_perl_data"); 711 $o->set_ob_key_value ("_perl_data");
626 712
627 %$o = %{ Storable::thaw pack "H*", $value }; 713 %$o = %{ Storable::thaw pack "H*", $value };
628 } 714 }
629 } 715 }
630 },
631 on_save => sub {
632 my ($pl, $path) = @_;
633
634 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
635 for grep %$_, all_objects $pl->ob;
636 }, 716 },
637; 717;
638 718
639############################################################################# 719#############################################################################
640# core extensions - in perl 720# core extensions - in perl
… …
779 $TICK_WATCHER->at ($NEXT_TICK); 859 $TICK_WATCHER->at ($NEXT_TICK);
780 $TICK_WATCHER->start; 860 $TICK_WATCHER->start;
781 }, 861 },
782); 862);
783 863
864_reload_2;
865
7841 8661
785 867

Diff Legend

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