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.45 by root, Sat Aug 26 23:36:32 2006 UTC

… …
13 13
14use strict; 14use strict;
15 15
16our %COMMAND = (); 16our %COMMAND = ();
17our @EVENT; 17our @EVENT;
18our @PLUGIN_EVENT;
19our %PROP_TYPE; 18our %PROP_TYPE;
20our %PROP_IDX; 19our %PROP_IDX;
21our $LIBDIR = maps_directory "perl"; 20our $LIBDIR = maps_directory "perl";
22 21
23our $TICK = MAX_TIME * 1e-6; 22our $TICK = MAX_TIME * 1e-6;
24our $TICK_WATCHER; 23our $TICK_WATCHER;
25our $NEXT_TICK; 24our $NEXT_TICK;
26 25
27BEGIN { 26BEGIN {
28 @PLUGIN_EVENT = map lc, @PLUGIN_EVENT;
29
30 *CORE::GLOBAL::warn = sub { 27 *CORE::GLOBAL::warn = sub {
31 my $msg = join "", @_; 28 my $msg = join "", @_;
32 $msg .= "\n" 29 $msg .= "\n"
33 unless $msg =~ /\n$/; 30 unless $msg =~ /\n$/;
34 31
… …
69prop_gen PLAYER_PROP => "cf::object::player"; 66prop_gen PLAYER_PROP => "cf::object::player";
70 67
71prop_gen MAP_PROP => "cf::map"; 68prop_gen MAP_PROP => "cf::map";
72prop_gen ARCH_PROP => "cf::arch"; 69prop_gen ARCH_PROP => "cf::arch";
73 70
74# guessed hierarchies
75
76@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 71@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
77@safe::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
78 72
79# we bless all objects into (empty) derived classes to force a method lookup 73# we bless all objects into (empty) derived classes to force a method lookup
80# within the Safe compartment. 74# 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)) { 75for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {
82 no strict 'refs'; 76 no strict 'refs';
83 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 77 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
84} 78}
85 79
86$Event::DIED = sub { 80$Event::DIED = sub {
… …
92my @hook; 86my @hook;
93my %command; 87my %command;
94my %extcmd; 88my %extcmd;
95 89
96############################################################################# 90#############################################################################
97# object support 91# utility functions
98 92
99sub reattach { 93use JSON::Syck (); # TODO# replace by JSON::PC once working
100 warn "reattach<@_>\n";
101}
102 94
103sub instantiate { 95sub from_json($) {
104 warn "instantiate<@_>\n"; 96 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
97 JSON::Syck::Load $_[0]
105} 98}
106 99
107sub clone { 100sub to_json($) {
108 warn "clone<@_>\n"; 101 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
102 JSON::Syck::Dump $_[0]
109} 103}
110 104
111############################################################################# 105#############################################################################
112# "new" plug-in system 106# "new" plug-in system
113 107
114=item cf::object::attach ... # NYI 108=item cf::object::attach ... # NYI
115 109
116=item cf::attach_global ... 110=item cf::attach_global ...
117 111
118=item cf::attach_to_type ... 112=item cf::attach_to_type $object_type, ...
119 113
120=item cf::attach_to_objects ... 114=item cf::attach_to_objects ...
121 115
122=item cf::attach_to_players ... 116=item cf::attach_to_players ...
123 117
124=item cf::attach_to_maps ... 118=item cf::attach_to_maps ...
119
120=item cf:register_attachment $name, ...
125 121
126 prio => $number, # lower is earlier 122 prio => $number, # lower is earlier
127 on_xxx => \&cb, 123 on_xxx => \&cb,
128 package => package::, 124 package => package::,
129 125
130=cut 126=cut
131 127
132# the following variables are defined in .xs and must not be re-created 128# the following variables are defined in .xs and must not be re-created
133our @CB_GLOBAL = (); # registry for all global events 129our @CB_GLOBAL = (); # registry for all global events
134our @CB_OBJECT = (); 130our @CB_OBJECT = (); # all objects (should not be used except in emergency)
135our @CB_PLAYER = (); 131our @CB_PLAYER = ();
136our @CB_TYPE = (); # registry for type (cf-object class) based events 132our @CB_TYPE = (); # registry for type (cf-object class) based events
137our @CB_MAP = (); 133our @CB_MAP = ();
138 134
135my %attachment;
136
139sub _attach_cb($\%$$$) { 137sub _attach_cb($\%$$$) {
140 my ($registry, $undo, $event, $prio, $cb) = @_; 138 my ($registry, $undo, $event, $prio, $cb) = @_;
141 139
142 use sort 'stable'; 140 use sort 'stable';
143 141
… …
151} 149}
152 150
153# attach handles attaching event callbacks 151# attach handles attaching event callbacks
154# the only thing the caller has to do is pass the correct 152# the only thing the caller has to do is pass the correct
155# registry (== where the callback attaches to). 153# registry (== where the callback attaches to).
156sub _attach(\@$\@) { 154sub _attach(\@$@) {
157 my ($registry, $klass, $arg) = @_; 155 my ($registry, $klass, @arg) = @_;
158 156
159 my $prio = 0; 157 my $prio = 0;
160 158
161 my %undo = ( 159 my %undo = (
162 registry => $registry, 160 registry => $registry,
163 cb => [], 161 cb => [],
164 ); 162 );
165 163
166 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; 164 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
167 165
168 while (@$arg) { 166 while (@arg) {
169 my $type = shift @$arg; 167 my $type = shift @arg;
170 168
171 if ($type eq "prio") { 169 if ($type eq "prio") {
172 $prio = shift @$arg; 170 $prio = shift @arg;
173 171
174 } elsif ($type eq "package") { 172 } elsif ($type eq "package") {
175 my $pkg = shift @$arg; 173 my $pkg = shift @arg;
176 174
177 while (my ($name, $id) = each %cb_id) { 175 while (my ($name, $id) = each %cb_id) {
178 if (my $cb = $pkg->can ($name)) { 176 if (my $cb = $pkg->can ($name)) {
179 _attach_cb $registry, %undo, $id, $prio, $cb; 177 _attach_cb $registry, %undo, $id, $prio, $cb;
180 } 178 }
181 } 179 }
182 180
183 } elsif (exists $cb_id{$type}) { 181 } elsif (exists $cb_id{$type}) {
184 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @$arg; 182 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg;
185 183
186 } elsif (ref $type) { 184 } elsif (ref $type) {
187 warn "attaching objects not supported, ignoring.\n"; 185 warn "attaching objects not supported, ignoring.\n";
188 186
189 } else { 187 } else {
190 shift @$arg; 188 shift @arg;
191 warn "attach argument '$type' not supported, ignoring.\n"; 189 warn "attach argument '$type' not supported, ignoring.\n";
192 } 190 }
193 } 191 }
194 192
195 \%undo 193 \%undo
… …
203 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 201 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
204} 202}
205 203
206sub attach_to_type { 204sub attach_to_type {
207 my $type = shift; 205 my $type = shift;
206
208 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_ 207 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_
209} 208}
210 209
211sub attach_to_objects { 210sub attach_to_objects {
212 _attach @CB_OBJECT, KLASS_OBJECT, @_ 211 _attach @CB_OBJECT, KLASS_OBJECT, @_
… …
218 217
219sub attach_to_maps { 218sub attach_to_maps {
220 _attach @CB_MAP, KLASS_MAP, @_ 219 _attach @CB_MAP, KLASS_MAP, @_
221} 220}
222 221
222sub register_attachment {
223 my $name = shift;
224
225 $attachment{$name} = [@_];
226}
227
223our $override; 228our $override;
229our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
224 230
225sub override() { 231sub override {
226 $override = 1 232 $override = 1;
233 @invoke_results = ();
227} 234}
228 235
229sub invoke { 236sub do_invoke {
230 my $event = shift; 237 my $event = shift;
231 my $callbacks = shift; 238 my $callbacks = shift;
239
240 @invoke_results = ();
232 241
233 local $override; 242 local $override;
234 243
235 for (@$callbacks) { 244 for (@$callbacks) {
236 eval { &{$_->[1]} }; 245 eval { &{$_->[1]} };
… …
246 255
247 0 256 0
248} 257}
249 258
250############################################################################# 259#############################################################################
260# object support
261
262sub instantiate {
263 my ($obj, $data) = @_;
264 my $registry = $obj->registry;
265
266 $data = from_json $data;
267
268 for (@$data) {
269 my ($pri, $name, @args) = @$_;
270
271 if (my $attach = $attachment{$name}) {
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 }
289}
290
291# basically do the same as instantiate, without calling instantiate
292sub reattach {
293 my ($obj) = @_;
294 my $registry = $obj->registry;
295
296 warn "reattach<@_, $_>\n";
297}
298
299attach_to_objects
300 prio => -1000000,
301 on_clone => sub {
302 my ($src, $dst) = @_;
303
304 @{$dst->registry} = @{$src->registry};
305 warn "registry clone ", join ":", @{$src->registry};#d#
306
307 %$dst = %$src;
308
309 $dst->{_attachment} = [@{ $src->{_attachment} }]
310 if exists $src->{_attachment};
311
312 warn "clone<@_>\n";#d#
313 },
314;
315
316#############################################################################
251# old plug-in events 317# old plug-in events
252 318
253sub inject_event { 319sub inject_event {
254 my $extension = shift; 320 my $extension = shift;
255 my $event_code = shift; 321 my $event_code = shift;
… …
299} 365}
300 366
301sub register { 367sub register {
302 my ($base, $pkg) = @_; 368 my ($base, $pkg) = @_;
303 369
304 for my $idx (0 .. $#PLUGIN_EVENT) { 370 #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} 371}
311 372
312sub load_extension { 373sub load_extension {
313 my ($path) = @_; 374 my ($path) = @_;
314 375
… …
345 my ($pkg) = @_; 406 my ($pkg) = @_;
346 407
347 warn "removing extension $pkg\n"; 408 warn "removing extension $pkg\n";
348 409
349 # remove hooks 410 # remove hooks
411 #TODO
350 for my $idx (0 .. $#PLUGIN_EVENT) { 412# for my $idx (0 .. $#PLUGIN_EVENT) {
351 delete $hook[$idx]{$pkg}; 413# delete $hook[$idx]{$pkg};
352 } 414# }
353 415
354 # remove commands 416 # remove commands
355 for my $name (keys %command) { 417 for my $name (keys %command) {
356 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 418 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
357 419
… …
423 Symbol::delete_package $k; 485 Symbol::delete_package $k;
424 } 486 }
425 487
426 # 4. get rid of safe::, as good as possible 488 # 4. get rid of safe::, as good as possible
427 Symbol::delete_package "safe::$_" 489 Symbol::delete_package "safe::$_"
428 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region); 490 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
429 491
430 # 5. remove register_script_function callbacks 492 # 5. remove register_script_function callbacks
431 # TODO 493 # TODO
432 494
433 # 6. unload cf.pm "a bit" 495 # 6. unload cf.pm "a bit"
… …
461 warn $_[0]; 523 warn $_[0];
462 $who->message ($_[0]); 524 $who->message ($_[0]);
463 }; 525 };
464 } 526 }
465}; 527};
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 528
482############################################################################# 529#############################################################################
483# extcmd framework, basically convert ext <msg> 530# extcmd framework, basically convert ext <msg>
484# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 531# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
485 532

Diff Legend

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