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.46 by root, Sun Aug 27 16:15:12 2006 UTC

… …
103} 103}
104 104
105############################################################################# 105#############################################################################
106# "new" plug-in system 106# "new" plug-in system
107 107
108=item cf::object::attach ... # NYI 108=item $object->attach ($attachment, ...)
109
110Attach a pre-registered attachment to an object.
111
112=item $player->attach ($attachment, ...)
113
114Attach a pre-registered attachment to a player.
115
116=item $map->attach ($attachment, ...) # not yet persistent
117
118Attach a pre-registered attachment to a map.
109 119
110=item cf::attach_global ... 120=item cf::attach_global ...
111 121
122Attach handlers for global events.
123
124This and all following C<attach_*>-functions expect any number of the
125following handler/hook descriptions:
126
127=over 4
128
129=item prio => $number
130
131Set the priority for all following handlers/hooks (unless overwritten
132by another C<prio> setting). Lower priority handlers get executed
133earlier. The default priority is C<0>, and many built-in handlers are
134registered at priority C<-1000>, so lower priorities should not be used
135unless you know what you are doing.
136
137=item on_I<event> => \&cb
138
139Call the given code reference whenever the named event happens (event is
140something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
141handlers are recognised generally depends on the type of object these
142handlers attach to).
143
144See F<include/eventinc.h> for the full list of events supported, and their
145class.
146
147=item package => package::
148
149Look for sub functions of the name C<< on_I<event> >> in the given
150package and register them. Only handlers for eevents supported by the
151object/class are recognised.
152
153=back
154
112=item cf::attach_to_type $object_type, ... 155=item cf::attach_to_type $object_type, ...
113 156
157Attach handlers for a specific object type (e.g. TRANSPORT).
158
114=item cf::attach_to_objects ... 159=item cf::attach_to_objects ...
115 160
161Attach 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
163the game.
164
116=item cf::attach_to_players ... 165=item cf::attach_to_players ...
117 166
167Attach handlers to all players.
168
118=item cf::attach_to_maps ... 169=item cf::attach_to_maps ...
119 170
171Attach handlers to all maps.
172
120=item cf:register_attachment $name, ... 173=item cf:register_attachment $name, ...
121
122 prio => $number, # lower is earlier
123 on_xxx => \&cb,
124 package => package::,
125 174
126=cut 175=cut
127 176
128# the following variables are defined in .xs and must not be re-created 177# the following variables are defined in .xs and must not be re-created
129our @CB_GLOBAL = (); # registry for all global events 178our @CB_GLOBAL = (); # registry for all global events
… …
191 } 240 }
192 241
193 \%undo 242 \%undo
194} 243}
195 244
245sub _attach_attachment {
246 my ($klass, $obj, $name, @args) = q_;
247
248 my $res;
249
250 if (my $attach = $attachment{$name}) {
251 my $registry = $obj->registry;
252
253 $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 }
264 } else {
265 warn "object uses attachment '$name' that is not available, postponing.\n";
266 }
267
268 push @{$obj->{_attachment}}, $name;
269
270 $res->{attachment} = $name;
271 $res
272}
273
196sub cf::object::attach { 274sub cf::object::attach {
197 die; 275 my ($obj, $name, @args) = @_;
276
277 _attach_attachment KLASS_OBJECT, $obj, $name, @args;
278}
279
280sub cf::player::attach {
281 my ($obj, $name, @args) = @_;
282
283 _attach_attachment KLASS_PLAYER, $obj, $name, @args;
284}
285
286sub cf::map::attach {
287 my ($obj, $name, @args) = @_;
288
289 _attach_attachment KLASS_MAP, $obj, $name, @args;
198} 290}
199 291
200sub attach_global { 292sub attach_global {
201 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 293 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
202} 294}
… …
259############################################################################# 351#############################################################################
260# object support 352# object support
261 353
262sub instantiate { 354sub instantiate {
263 my ($obj, $data) = @_; 355 my ($obj, $data) = @_;
356
357 $data = from_json $data;
358
359 for (@$data) {
360 my ($name, $args) = @$_;
361 attach $obj, $name, @{$args || [] };
362 }
363}
364
365# basically do the same as instantiate, without calling instantiate
366sub reattach {
367 warn "reattach<@_>\n";#d#
368 my ($obj) = @_;
264 my $registry = $obj->registry; 369 my $registry = $obj->registry;
265 370
266 $data = from_json $data; 371 for my $name (@{ $obj->{_attachment} }) {
267
268 for (@$data) {
269 my ($pri, $name, @args) = @$_;
270
271 if (my $attach = $attachment{$name}) { 372 if (my $attach = $attachment{$name}) {
272 _attach @$registry, KLASS_OBJECT, @$attach; 373 _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 { 374 } else {
284 warn "object uses attachment $name that is not available, postponing.\n"; 375 warn "object uses attachment '$name' that is not available, postponing.\n";
285 } 376 }
286
287 push @{$obj->{_attachment}}, $name;
288 } 377 }
289}
290
291# basically do the same as instantiate, without calling instantiate
292sub reattach {
293 my ($obj) = @_;
294 my $registry = $obj->registry;
295 378
296 warn "reattach<@_, $_>\n"; 379 warn "reattach<@_, $_>\n";
380}
381
382sub object_freezer_save {
383 my ($filename, $objs) = @_;
384 warn "freeze $filename\n";#d#
385 use Data::Dumper; print Dumper $objs;
386
387 $filename .= ".pst";
388
389 if (@$objs) {
390 open my $fh, ">:raw", "$filename~";
391 chmod $fh, SAVE_MODE;
392 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
393 close $fh;
394 rename "$filename~", $filename;
395 } else {
396 unlink $filename;
397 }
398}
399
400sub object_thawer_load {
401 my ($filename) = @_;
402
403 warn "thaw $filename\n";#d#
404
405 open my $fh, "<:raw:perlio", "$filename.pst"
406 or return;
407
408 eval { local $/; (Storable::thaw <$fh>)->{objs} }
297} 409}
298 410
299attach_to_objects 411attach_to_objects
300 prio => -1000000, 412 prio => -1000000,
301 on_clone => sub { 413 on_clone => sub {
… …
558 670
559 my $path = $map->tmpname; 671 my $path = $map->tmpname;
560 defined $path or return; 672 defined $path or return;
561 673
562 unlink "$path.cfperl"; 674 unlink "$path.cfperl";
675 unlink "$path.pst";
563}; 676};
564 677
565*cf::mapsupport::on_swapin = 678*cf::mapsupport::on_swapin =
566*cf::mapsupport::on_load = sub { 679*cf::mapsupport::on_load = sub {
567 my ($map) = @_; 680 my ($map) = @_;
… …
578 or return; # too new 691 or return; # too new
579 692
580 $map->_set_obs ($data->{obs}); 693 $map->_set_obs ($data->{obs});
581}; 694};
582 695
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};
609
610attach_to_maps prio => -10000, package => cf::mapsupport::; 696attach_to_maps prio => -10000, package => cf::mapsupport::;
611 697
612############################################################################# 698#############################################################################
613# load/save perl data associated with player->ob objects 699# load/save perl data associated with player->ob objects
614 700
… …
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

Diff Legend

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