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.44 by root, Sat Aug 26 08:44:06 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 @PLUGIN_EVENT;
19our %PROP_TYPE; 20our %PROP_TYPE;
20our %PROP_IDX; 21our %PROP_IDX;
21our $LIBDIR = maps_directory "perl"; 22our $LIBDIR = maps_directory "perl";
22 23
23our $TICK = MAX_TIME * 1e-6; 24our $TICK = MAX_TIME * 1e-6;
24our $TICK_WATCHER; 25our $TICK_WATCHER;
25our $NEXT_TICK; 26our $NEXT_TICK;
26 27
27BEGIN { 28BEGIN {
28 @PLUGIN_EVENT = map lc, @PLUGIN_EVENT;
29
30 *CORE::GLOBAL::warn = sub { 29 *CORE::GLOBAL::warn = sub {
31 my $msg = join "", @_; 30 my $msg = join "", @_;
32 $msg .= "\n" 31 $msg .= "\n"
33 unless $msg =~ /\n$/; 32 unless $msg =~ /\n$/;
34 33
… …
69prop_gen PLAYER_PROP => "cf::object::player"; 68prop_gen PLAYER_PROP => "cf::object::player";
70 69
71prop_gen MAP_PROP => "cf::map"; 70prop_gen MAP_PROP => "cf::map";
72prop_gen ARCH_PROP => "cf::arch"; 71prop_gen ARCH_PROP => "cf::arch";
73 72
74# guessed hierarchies
75
76@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 73@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
77@safe::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
78 74
79# 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
80# within the Safe compartment. 76# within the Safe compartment.
81for my $pkg (qw(cf::object cf::object::map 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)) {
82 no strict 'refs'; 78 no strict 'refs';
83 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 79 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
84} 80}
85 81
86$Event::DIED = sub { 82$Event::DIED = sub {
… …
92my @hook; 88my @hook;
93my %command; 89my %command;
94my %extcmd; 90my %extcmd;
95 91
96############################################################################# 92#############################################################################
97# object support 93# utility functions
98 94
99sub reattach { 95use JSON::Syck (); # TODO# replace by JSON::PC once working
100 warn "reattach<@_>\n";
101}
102 96
103sub instantiate { 97sub from_json($) {
104 warn "instantiate<@_>\n"; 98 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
99 JSON::Syck::Load $_[0]
105} 100}
106 101
107sub clone { 102sub to_json($) {
108 warn "clone<@_>\n"; 103 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
104 JSON::Syck::Dump $_[0]
109} 105}
110 106
111############################################################################# 107#############################################################################
112# "new" plug-in system 108# "new" plug-in system
113 109
114=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.
115 121
116=item cf::attach_global ... 122=item cf::attach_global ...
117 123
118=item cf::attach_to_type ... 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
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.
119 162
120=item cf::attach_to_objects ... 163=item cf::attach_to_objects ...
121 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
122=item cf::attach_to_players ... 169=item cf::attach_to_players ...
123 170
171Attach handlers to all players.
172
124=item cf::attach_to_maps ... 173=item cf::attach_to_maps ...
125 174
126 prio => $number, # lower is earlier 175Attach handlers to all maps.
127 on_xxx => \&cb, 176
128 package => package::, 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.
129 186
130=cut 187=cut
131 188
132# 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
133our @CB_GLOBAL = (); # registry for all global events 190our @CB_GLOBAL = (); # registry for all global events
134our @CB_OBJECT = (); 191our @CB_OBJECT = (); # all objects (should not be used except in emergency)
135our @CB_PLAYER = (); 192our @CB_PLAYER = ();
136our @CB_TYPE = (); # registry for type (cf-object class) based events 193our @CB_TYPE = (); # registry for type (cf-object class) based events
137our @CB_MAP = (); 194our @CB_MAP = ();
138 195
196my %attachment;
197
139sub _attach_cb($\%$$$) { 198sub _attach_cb($\%$$$) {
140 my ($registry, $undo, $event, $prio, $cb) = @_; 199 my ($registry, $undo, $event, $prio, $cb) = @_;
141 200
142 use sort 'stable'; 201 use sort 'stable';
143 202
… …
151} 210}
152 211
153# attach handles attaching event callbacks 212# attach handles attaching event callbacks
154# the only thing the caller has to do is pass the correct 213# the only thing the caller has to do is pass the correct
155# registry (== where the callback attaches to). 214# registry (== where the callback attaches to).
156sub _attach(\@$\@) { 215sub _attach(\@$@) {
157 my ($registry, $klass, $arg) = @_; 216 my ($registry, $klass, @arg) = @_;
158 217
159 my $prio = 0; 218 my $prio = 0;
160 219
161 my %undo = ( 220 my %undo = (
162 registry => $registry, 221 registry => $registry,
163 cb => [], 222 cb => [],
164 ); 223 );
165 224
166 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; 225 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
167 226
168 while (@$arg) { 227 while (@arg) {
169 my $type = shift @$arg; 228 my $type = shift @arg;
170 229
171 if ($type eq "prio") { 230 if ($type eq "prio") {
172 $prio = shift @$arg; 231 $prio = shift @arg;
173 232
174 } elsif ($type eq "package") { 233 } elsif ($type eq "package") {
175 my $pkg = shift @$arg; 234 my $pkg = shift @arg;
176 235
177 while (my ($name, $id) = each %cb_id) { 236 while (my ($name, $id) = each %cb_id) {
178 if (my $cb = $pkg->can ($name)) { 237 if (my $cb = $pkg->can ($name)) {
179 _attach_cb $registry, %undo, $id, $prio, $cb; 238 _attach_cb $registry, %undo, $id, $prio, $cb;
180 } 239 }
181 } 240 }
182 241
183 } elsif (exists $cb_id{$type}) { 242 } elsif (exists $cb_id{$type}) {
184 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @$arg; 243 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg;
185 244
186 } elsif (ref $type) { 245 } elsif (ref $type) {
187 warn "attaching objects not supported, ignoring.\n"; 246 warn "attaching objects not supported, ignoring.\n";
188 247
189 } else { 248 } else {
190 shift @$arg; 249 shift @arg;
191 warn "attach argument '$type' not supported, ignoring.\n"; 250 warn "attach argument '$type' not supported, ignoring.\n";
192 } 251 }
193 } 252 }
194 253
195 \%undo 254 \%undo
196} 255}
197 256
257sub _attach_attachment {
258 my ($obj, $name, %arg) = @_;
259
260 my $res;
261
262 if (my $attach = $attachment{$name}) {
263 my $registry = $obj->registry;
264
265 for (@$attach) {
266 my ($klass, @attach) = @$_;
267 $res = _attach @$registry, $klass, @attach;
268 }
269
270 $obj->{$name} = \%arg;
271 } else {
272 warn "object uses attachment '$name' that is not available, postponing.\n";
273 }
274
275 $obj->{_attachment}{$name} = undef;
276
277 $res->{attachment} = $name;
278 $res
279}
280
198sub cf::object::attach { 281sub cf::object::attach {
199 die; 282 my ($obj, $name, %arg) = @_;
283
284 _attach_attachment $obj, $name, %arg;
285}
286
287sub cf::player::attach {
288 my ($obj, $name, %arg) = @_;
289
290 _attach_attachment $obj, $name, %arg;
291}
292
293sub cf::map::attach {
294 my ($obj, $name, %arg) = @_;
295
296 _attach_attachment $obj, $name, %arg;
200} 297}
201 298
202sub attach_global { 299sub attach_global {
203 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 300 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
204} 301}
205 302
206sub attach_to_type { 303sub attach_to_type {
207 my $type = shift; 304 my $type = shift;
305 my $subtype = shift;
306
208 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_ 307 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
209} 308}
210 309
211sub attach_to_objects { 310sub attach_to_objects {
212 _attach @CB_OBJECT, KLASS_OBJECT, @_ 311 _attach @CB_OBJECT, KLASS_OBJECT, @_
213} 312}
… …
218 317
219sub attach_to_maps { 318sub attach_to_maps {
220 _attach @CB_MAP, KLASS_MAP, @_ 319 _attach @CB_MAP, KLASS_MAP, @_
221} 320}
222 321
322sub register_attachment {
323 my $name = shift;
324
325 $attachment{$name} = [[KLASS_OBJECT, @_]];
326}
327
328sub register_map_attachment {
329 my $name = shift;
330
331 $attachment{$name} = [[KLASS_MAP, @_]];
332}
333
223our $override; 334our $override;
335our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
224 336
225sub override() { 337sub override {
226 $override = 1 338 $override = 1;
339 @invoke_results = ();
227} 340}
228 341
229sub invoke { 342sub do_invoke {
230 my $event = shift; 343 my $event = shift;
231 my $callbacks = shift; 344 my $callbacks = shift;
345
346 @invoke_results = ();
232 347
233 local $override; 348 local $override;
234 349
235 for (@$callbacks) { 350 for (@$callbacks) {
236 eval { &{$_->[1]} }; 351 eval { &{$_->[1]} };
… …
246 361
247 0 362 0
248} 363}
249 364
250############################################################################# 365#############################################################################
366# object support
367
368sub instantiate {
369 my ($obj, $data) = @_;
370
371 $data = from_json $data;
372
373 for (@$data) {
374 my ($name, $args) = @$_;
375
376 $obj->attach ($name, %{$args || {} });
377 }
378}
379
380# basically do the same as instantiate, without calling instantiate
381sub reattach {
382 my ($obj) = @_;
383 my $registry = $obj->registry;
384
385 @$registry = ();
386
387 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
388
389 for my $name (keys %{ $obj->{_attachment} || {} }) {
390 if (my $attach = $attachment{$name}) {
391 for (@$attach) {
392 my ($klass, @attach) = @$_;
393 _attach @$registry, $klass, @attach;
394 }
395 } else {
396 warn "object uses attachment '$name' that is not available, postponing.\n";
397 }
398 }
399}
400
401sub object_freezer_save {
402 my ($filename, $objs) = @_;
403
404 if (@$objs) {
405 open my $fh, ">:raw", "$filename.pst~";
406 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
407 close $fh;
408 chmod SAVE_MODE, "$filename.pst~";
409 rename "$filename.pst~", "$filename.pst";
410 } else {
411 unlink "$filename.pst";
412 }
413
414 chmod SAVE_MODE, "$filename~";
415 rename "$filename~", $filename;
416}
417
418sub object_thawer_load {
419 my ($filename) = @_;
420
421 open my $fh, "<:raw:perlio", "$filename.pst"
422 or return;
423
424 eval { local $/; (Storable::thaw <$fh>)->{objs} }
425}
426
427attach_to_objects
428 prio => -1000000,
429 on_clone => sub {
430 my ($src, $dst) = @_;
431
432 @{$dst->registry} = @{$src->registry};
433
434 %$dst = %$src;
435
436 %{$dst->{_attachment}} = %{$src->{_attachment}}
437 if exists $src->{_attachment};
438 },
439;
440
441#############################################################################
251# old plug-in events 442# old plug-in events
252 443
253sub inject_event { 444sub inject_event {
254 my $extension = shift; 445 my $extension = shift;
255 my $event_code = shift; 446 my $event_code = shift;
… …
299} 490}
300 491
301sub register { 492sub register {
302 my ($base, $pkg) = @_; 493 my ($base, $pkg) = @_;
303 494
304 for my $idx (0 .. $#PLUGIN_EVENT) { 495 #TODO
305 if (my $ref = $pkg->can ("on_$PLUGIN_EVENT[$idx]")) {
306 #warn "registering $PLUGIN_EVENT[$idx] hook to '$pkg'\n";
307 $hook[$idx]{$base} = $ref;
308 }
309 }
310} 496}
311 497
312sub load_extension { 498sub load_extension {
313 my ($path) = @_; 499 my ($path) = @_;
314 500
… …
345 my ($pkg) = @_; 531 my ($pkg) = @_;
346 532
347 warn "removing extension $pkg\n"; 533 warn "removing extension $pkg\n";
348 534
349 # remove hooks 535 # remove hooks
536 #TODO
350 for my $idx (0 .. $#PLUGIN_EVENT) { 537# for my $idx (0 .. $#PLUGIN_EVENT) {
351 delete $hook[$idx]{$pkg}; 538# delete $hook[$idx]{$pkg};
352 } 539# }
353 540
354 # remove commands 541 # remove commands
355 for my $name (keys %command) { 542 for my $name (keys %command) {
356 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 543 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
357 544
… …
423 Symbol::delete_package $k; 610 Symbol::delete_package $k;
424 } 611 }
425 612
426 # 4. get rid of safe::, as good as possible 613 # 4. get rid of safe::, as good as possible
427 Symbol::delete_package "safe::$_" 614 Symbol::delete_package "safe::$_"
428 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region); 615 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
429 616
430 # 5. remove register_script_function callbacks 617 # 5. remove register_script_function callbacks
431 # TODO 618 # TODO
432 619
433 # 6. unload cf.pm "a bit" 620 # 6. unload cf.pm "a bit"
… …
461 warn $_[0]; 648 warn $_[0];
462 $who->message ($_[0]); 649 $who->message ($_[0]);
463 }; 650 };
464 } 651 }
465}; 652};
466
467#############################################################################
468# utility functions
469
470use JSON::Syck (); # TODO# replace by JSON::PC once working
471
472sub from_json($) {
473 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
474 JSON::Syck::Load $_[0]
475}
476
477sub to_json($) {
478 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
479 JSON::Syck::Dump $_[0]
480}
481 653
482############################################################################# 654#############################################################################
483# extcmd framework, basically convert ext <msg> 655# extcmd framework, basically convert ext <msg>
484# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 656# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
485 657
… …
510 my ($map) = @_; 682 my ($map) = @_;
511 683
512 my $path = $map->tmpname; 684 my $path = $map->tmpname;
513 defined $path or return; 685 defined $path or return;
514 686
515 unlink "$path.cfperl"; 687 unlink "$path.pst";
516}; 688};
517 689
690# old style persistent data, TODO: remove #d#
518*cf::mapsupport::on_swapin = 691*cf::mapsupport::on_swapin =
519*cf::mapsupport::on_load = sub { 692*cf::mapsupport::on_load = sub {
520 my ($map) = @_; 693 my ($map) = @_;
521 694
522 my $path = $map->tmpname; 695 my $path = $map->tmpname;
… …
529 702
530 $data->{version} <= 1 703 $data->{version} <= 1
531 or return; # too new 704 or return; # too new
532 705
533 $map->_set_obs ($data->{obs}); 706 $map->_set_obs ($data->{obs});
534}; 707 $map->invoke (EVENT_MAP_UPGRADE);
535
536*cf::mapsupport::on_swapout = sub {
537 my ($map) = @_;
538
539 my $path = $map->tmpname;
540 $path = $map->path unless defined $path;
541
542 my $obs = $map->_get_obs;
543
544 if (defined $obs) {
545 open my $fh, ">:raw", "$path.cfperl"
546 or die "$path.cfperl: $!";
547
548 stat $path;
549
550 print $fh Storable::nfreeze {
551 size => (stat _)[7],
552 time => (stat _)[9],
553 version => 1,
554 obs => $obs,
555 };
556
557 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
558 } else {
559 unlink "$path.cfperl";
560 }
561}; 708};
562 709
563attach_to_maps prio => -10000, package => cf::mapsupport::; 710attach_to_maps prio => -10000, package => cf::mapsupport::;
564 711
565############################################################################# 712#############################################################################
… …
578 $o->set_ob_key_value ("_perl_data"); 725 $o->set_ob_key_value ("_perl_data");
579 726
580 %$o = %{ Storable::thaw pack "H*", $value }; 727 %$o = %{ Storable::thaw pack "H*", $value };
581 } 728 }
582 } 729 }
583 },
584 on_save => sub {
585 my ($pl, $path) = @_;
586
587 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
588 for grep %$_, all_objects $pl->ob;
589 }, 730 },
590; 731;
591 732
592############################################################################# 733#############################################################################
593# core extensions - in perl 734# core extensions - in perl
… …
732 $TICK_WATCHER->at ($NEXT_TICK); 873 $TICK_WATCHER->at ($NEXT_TICK);
733 $TICK_WATCHER->start; 874 $TICK_WATCHER->start;
734 }, 875 },
735); 876);
736 877
878_reload_2;
879
7371 8801
738 881

Diff Legend

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