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.5 by root, Wed Feb 8 03:46:15 2006 UTC vs.
Revision 1.20 by root, Sun Jul 16 17:29:02 2006 UTC

1package cf; 1package cf;
2 2
3use Symbol; 3use Symbol;
4use List::Util; 4use List::Util;
5use Storable;
6
7use Event;
8$Event::Eval = 1; # no idea why this is required, but it is
5 9
6use strict; 10use strict;
7 11
8our %COMMAND; 12our %COMMAND;
9our @EVENT; 13our @EVENT;
… …
21 print STDERR "cfperl: $msg"; 25 print STDERR "cfperl: $msg";
22 LOG llevError, "cfperl: $msg"; 26 LOG llevError, "cfperl: $msg";
23 }; 27 };
24} 28}
25 29
30my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply!
31
26# generate property mutators 32# generate property mutators
27sub prop_gen { 33sub prop_gen {
28 my ($prefix, $class) = @_; 34 my ($prefix, $class) = @_;
29 35
30 no strict 'refs'; 36 no strict 'refs';
… …
40 $_[0]->get_property ($type, $idx) 46 $_[0]->get_property ($type, $idx)
41 }; 47 };
42 48
43 *{"$class\::set_$sub"} = sub { 49 *{"$class\::set_$sub"} = sub {
44 $_[0]->set_property ($type, $idx, $_[1]); 50 $_[0]->set_property ($type, $idx, $_[1]);
45 }; 51 } unless $ignore_set{$prop};
46 } 52 }
47} 53}
48 54
49# auto-generate most of the API 55# auto-generate most of the API
50 56
… …
57 63
58# guessed hierarchies 64# guessed hierarchies
59 65
60@cf::object::player::ISA = 'cf::object'; 66@cf::object::player::ISA = 'cf::object';
61@cf::object::map::ISA = 'cf::object'; 67@cf::object::map::ISA = 'cf::object';
68
69$Event::DIED = sub {
70 warn "error in event callback: @_";
71};
62 72
63my %ext_pkg; 73my %ext_pkg;
64my @exts; 74my @exts;
65my @hook; 75my @hook;
66my %command; 76my %command;
77my %extcmd;
67 78
68sub inject_event { 79sub inject_event {
69 my ($data) = @_; 80 my $extension = shift;
81 my $event_code = shift;
70 82
71 my $cb = $hook[$data->{event_code}]{$data->{extension}} 83 my $cb = $hook[$event_code]{$extension}
72 or return; 84 or return;
73 85
74 $cb->($data) 86 &$cb
75} 87}
76 88
77sub inject_global_event { 89sub inject_global_event {
78 my ($data) = @_; 90 my $event = shift;
79 91
80 my $cb = $hook[$data->{event_code}] 92 my $cb = $hook[$event]
81 or return; 93 or return;
82 94
83 $_->($data) for values %$cb; 95 List::Util::max map &$_, values %$cb
84
85 ()
86} 96}
87 97
88sub inject_command { 98sub inject_command {
89 my ($name, $obj, $params) = @_; 99 my ($name, $obj, $params) = @_;
90 100
… …
97 107
98sub register_command { 108sub register_command {
99 my ($name, $time, $cb) = @_; 109 my ($name, $time, $cb) = @_;
100 110
101 my $caller = caller; 111 my $caller = caller;
102
103 warn "registering command '$name/$time' to '$caller'"; 112 #warn "registering command '$name/$time' to '$caller'";
104 113
105 push @{ $command{$name} }, [$time, $cb, $caller]; 114 push @{ $command{$name} }, [$time, $cb, $caller];
106 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} }; 115 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
116}
117
118sub register_extcmd {
119 my ($name, $cb) = @_;
120
121 my $caller = caller;
122 #warn "registering extcmd '$name' to '$caller'";
123
124 $extcmd{$name} = [$cb, $caller];
125}
126
127sub register {
128 my ($base, $pkg) = @_;
129
130 for my $idx (0 .. $#EVENT) {
131 if (my $ref = $pkg->can ("on_$EVENT[$idx]")) {
132 #warn "registering $EVENT[$idx] hook to '$pkg'\n";
133 $hook[$idx]{$base} = $ref;
134 }
135 }
107} 136}
108 137
109sub load_extension { 138sub load_extension {
110 my ($path) = @_; 139 my ($path) = @_;
111 140
… …
130 or die "$path: $@"; 159 or die "$path: $@";
131 160
132 push @exts, $pkg; 161 push @exts, $pkg;
133 $ext_pkg{$base} = $pkg; 162 $ext_pkg{$base} = $pkg;
134 163
135 no strict 'refs'; 164# no strict 'refs';
136
137# @{"$pkg\::ISA"} = cf::ext::; 165# @{"$pkg\::ISA"} = cf::ext::;
138 166
139 for my $idx (0 .. $#EVENT) { 167 register $base, $pkg;
140 if (my $ref = $pkg->can ("on_$EVENT[$idx]")) {
141 warn "registering $EVENT[$idx] hook\n";
142 $hook[$idx]{$base} = $ref;
143 }
144 }
145} 168}
146 169
147sub unload_extension { 170sub unload_extension {
148 my ($pkg) = @_; 171 my ($pkg) = @_;
149 172
… …
165 delete $command{$name}; 188 delete $command{$name};
166 delete $COMMAND{"$name\000"}; 189 delete $COMMAND{"$name\000"};
167 } 190 }
168 } 191 }
169 192
193 # remove extcmds
194 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
195 delete $extcmd{$name};
196 }
197
170 Symbol::delete_package $pkg; 198 Symbol::delete_package $pkg;
171} 199}
172 200
173sub load_extensions { 201sub load_extensions {
174 my $LIBDIR = maps_directory "perl"; 202 my $LIBDIR = maps_directory "perl";
… …
188 if ($who->flag (FLAG_WIZ)) { 216 if ($who->flag (FLAG_WIZ)) {
189 $who->message ("reloading..."); 217 $who->message ("reloading...");
190 218
191 warn "reloading...\n"; 219 warn "reloading...\n";
192 eval { 220 eval {
221 $_->cancel for Event::all_watchers;
222
193 unload_extension $_ for @exts; 223 unload_extension $_ for @exts;
194 delete $INC{"cf.pm"}; 224 delete $INC{"cf.pm"};
195 225
196 # don't, removes xs symbols, too 226 # don't, removes xs symbols, too
197 #Symbol::delete_package $pkg; 227 #Symbol::delete_package $pkg;
… …
206 } else { 236 } else {
207 $who->message ("Intruder Alert!"); 237 $who->message ("Intruder Alert!");
208 } 238 }
209}; 239};
210 240
241#############################################################################
242# extcmd framework, basically convert ext <id> <pkg> arg1 args
243# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
244
245sub on_extcmd {
246 my ($pl, $buf) = @_;
247
248 my ($type) = $buf =~ s/^(\S+) // ? $1 : "";
249
250 $extcmd{$type}[0]->($pl, $buf)
251 if $extcmd{$type};
252}
253
254#############################################################################
255# load/save/clean perl data associated with a map
256
257*on_mapclean = sub {
258 my ($map) = @_;
259
260 my $path = $map->tmpname;
261 defined $path or return;
262
263 unlink "$path.cfperl";
264};
265
266*on_mapin =
267*on_mapload = sub {
268 my ($map) = @_;
269
270 my $path = $map->tmpname;
271 $path = $map->path unless defined $path;
272
273 open my $fh, "<:raw", "$path.cfperl"
274 or return; # no perl data
275
276 my $data = Storable::thaw do { local $/; <$fh> };
277
278 $data->{version} <= 1
279 or return; # too new
280
281 $map->_set_obs ($data->{obs});
282};
283
284*on_mapout = sub {
285 my ($map) = @_;
286
287 my $path = $map->tmpname;
288 $path = $map->path unless defined $path;
289
290 my $obs = $map->_get_obs;
291
292 if (defined $obs) {
293 open my $fh, ">:raw", "$path.cfperl"
294 or die "$path.cfperl: $!";
295
296 stat $path;
297
298 print $fh Storable::nfreeze {
299 size => (stat _)[7],
300 time => (stat _)[9],
301 version => 1,
302 obs => $obs,
303 };
304
305 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
306 } else {
307 unlink "$path.cfperl";
308 }
309};
310
311#############################################################################
312# load/save perl data associated with player->ob objects
313
314*on_player_load = sub {
315 my ($ob, $path) = @_;
316
317 if (open my $fh, "<:raw", "$path.cfperl") {
318
319 #d##TODO#remove
320
321 my $data = Storable::thaw do { local $/; <$fh> };
322
323 $data->{version} <= 1
324 or return; # too new
325
326 %$ob = %{$data->{ob}};
327 return;
328 }
329
330 for my $o ($ob, $ob->inv) {
331 if (my $value = $o->get_ob_key_value ("_perl_data")) {
332 $o->set_ob_key_value ("_perl_data");
333
334 %$o = %{ Storable::thaw pack "H*", $value };
335 }
336 }
337};
338
339*on_player_save = sub {
340 my ($ob, $path) = @_;
341
342 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
343 for grep %$_, $ob, $ob->inv;
344
345 unlink "$path.cfperl";#d##TODO#remove
346};
347
348register "<global>", __PACKAGE__;
349
350unshift @INC, maps_directory "perl";
351
211load_extensions; 352load_extensions;
212 353
2131 3541
214 355

Diff Legend

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