ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
Revision: 1.26
Committed: Thu Jul 20 22:03:36 2006 UTC (17 years, 10 months ago) by root
Branch: MAIN
Changes since 1.25: +0 -15 lines
Log Message:
removed compatibility to ancient cfperl versions

File Contents

# User Rev Content
1 root 1.1 package cf;
2    
3     use Symbol;
4     use List::Util;
5 root 1.6 use Storable;
6 root 1.23 use Opcode;
7     use Safe;
8     use Safe::Hole;
9 root 1.19
10 root 1.18 use Event;
11 root 1.19 $Event::Eval = 1; # no idea why this is required, but it is
12 root 1.1
13     use strict;
14    
15     our %COMMAND;
16     our @EVENT;
17     our %PROP_TYPE;
18     our %PROP_IDX;
19    
20     BEGIN {
21     @EVENT = map lc, @EVENT;
22    
23     *CORE::GLOBAL::warn = sub {
24     my $msg = join "", @_;
25     $msg .= "\n"
26     unless $msg =~ /\n$/;
27    
28     print STDERR "cfperl: $msg";
29     LOG llevError, "cfperl: $msg";
30     };
31     }
32    
33 root 1.9 my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply!
34    
35 root 1.1 # generate property mutators
36     sub prop_gen {
37     my ($prefix, $class) = @_;
38    
39     no strict 'refs';
40    
41     for my $prop (keys %PROP_TYPE) {
42     $prop =~ /^\Q$prefix\E_(.*$)/ or next;
43     my $sub = lc $1;
44    
45     my $type = $PROP_TYPE{$prop};
46     my $idx = $PROP_IDX {$prop};
47    
48     *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
49     $_[0]->get_property ($type, $idx)
50     };
51    
52     *{"$class\::set_$sub"} = sub {
53     $_[0]->set_property ($type, $idx, $_[1]);
54 root 1.9 } unless $ignore_set{$prop};
55 root 1.1 }
56     }
57    
58     # auto-generate most of the API
59    
60     prop_gen OBJECT_PROP => "cf::object";
61     # CFAPI_OBJECT_ANIMATION?
62     prop_gen PLAYER_PROP => "cf::object::player";
63    
64     prop_gen MAP_PROP => "cf::map";
65     prop_gen ARCH_PROP => "cf::arch";
66    
67     # guessed hierarchies
68    
69 root 1.25 @ext::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
70     @ext::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
71    
72     # we bless all objects into derived classes to force a method lookup
73     # within the Safe compartment.
74     for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region)) {
75     no strict 'refs';
76     @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
77     }
78 root 1.1
79 root 1.18 $Event::DIED = sub {
80     warn "error in event callback: @_";
81     };
82    
83 root 1.5 my %ext_pkg;
84 root 1.1 my @exts;
85     my @hook;
86     my %command;
87 root 1.15 my %extcmd;
88 root 1.1
89     sub inject_event {
90 root 1.14 my $extension = shift;
91     my $event_code = shift;
92 root 1.1
93 root 1.14 my $cb = $hook[$event_code]{$extension}
94 root 1.5 or return;
95    
96 root 1.14 &$cb
97 root 1.5 }
98    
99     sub inject_global_event {
100 root 1.12 my $event = shift;
101 root 1.5
102 root 1.12 my $cb = $hook[$event]
103 root 1.1 or return;
104    
105 root 1.12 List::Util::max map &$_, values %$cb
106 root 1.1 }
107    
108     sub inject_command {
109     my ($name, $obj, $params) = @_;
110    
111     for my $cmd (@{ $command{$name} }) {
112     $cmd->[1]->($obj, $params);
113     }
114    
115     -1
116     }
117    
118     sub register_command {
119     my ($name, $time, $cb) = @_;
120    
121     my $caller = caller;
122 root 1.16 #warn "registering command '$name/$time' to '$caller'";
123 root 1.4
124 root 1.1 push @{ $command{$name} }, [$time, $cb, $caller];
125     $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
126     }
127    
128 root 1.16 sub register_extcmd {
129     my ($name, $cb) = @_;
130    
131     my $caller = caller;
132     #warn "registering extcmd '$name' to '$caller'";
133    
134     $extcmd{$name} = [$cb, $caller];
135     }
136    
137 root 1.6 sub register {
138     my ($base, $pkg) = @_;
139    
140     for my $idx (0 .. $#EVENT) {
141     if (my $ref = $pkg->can ("on_$EVENT[$idx]")) {
142 root 1.16 #warn "registering $EVENT[$idx] hook to '$pkg'\n";
143 root 1.6 $hook[$idx]{$base} = $ref;
144     }
145     }
146     }
147    
148 root 1.1 sub load_extension {
149     my ($path) = @_;
150    
151     $path =~ /([^\/\\]+)\.ext$/ or die "$path";
152 root 1.5 my $base = $1;
153 root 1.1 my $pkg = $1;
154     $pkg =~ s/[^[:word:]]/_/g;
155     $pkg = "cf::ext::$pkg";
156    
157     warn "loading '$path' into '$pkg'\n";
158    
159     open my $fh, "<:utf8", $path
160     or die "$path: $!";
161    
162     my $source =
163     "package $pkg; use strict; use utf8;\n"
164     . "#line 1 \"$path\"\n{\n"
165     . (do { local $/; <$fh> })
166     . "\n};\n1";
167    
168     eval $source
169     or die "$path: $@";
170    
171     push @exts, $pkg;
172 root 1.5 $ext_pkg{$base} = $pkg;
173 root 1.1
174 root 1.6 # no strict 'refs';
175 root 1.23 # @{"$pkg\::ISA"} = ext::;
176 root 1.1
177 root 1.6 register $base, $pkg;
178 root 1.1 }
179    
180     sub unload_extension {
181     my ($pkg) = @_;
182    
183     warn "removing extension $pkg\n";
184    
185 root 1.21 if (my $cb = $pkg->can ("on_unload")) {
186     $cb->($pkg);
187     }
188    
189 root 1.1 # remove hooks
190     for my $idx (0 .. $#EVENT) {
191     delete $hook[$idx]{$pkg};
192     }
193    
194     # remove commands
195     for my $name (keys %command) {
196     my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
197    
198     if (@cb) {
199     $command{$name} = \@cb;
200     $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
201     } else {
202     delete $command{$name};
203     delete $COMMAND{"$name\000"};
204     }
205     }
206    
207 root 1.15 # remove extcmds
208 root 1.16 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
209     delete $extcmd{$name};
210 root 1.15 }
211    
212 root 1.1 Symbol::delete_package $pkg;
213     }
214    
215     sub load_extensions {
216     my $LIBDIR = maps_directory "perl";
217    
218     for my $ext (<$LIBDIR/*.ext>) {
219 root 1.3 next unless -r $ext;
220 root 1.2 eval {
221     load_extension $ext;
222     1
223     } or warn "$ext not loaded: $@";
224 root 1.1 }
225     }
226    
227     register_command "perl-reload", 0, sub {
228     my ($who, $arg) = @_;
229    
230     if ($who->flag (FLAG_WIZ)) {
231 root 1.3 $who->message ("reloading...");
232    
233 root 1.1 warn "reloading...\n";
234 root 1.4 eval {
235 root 1.20 $_->cancel for Event::all_watchers;
236    
237 root 1.4 unload_extension $_ for @exts;
238     delete $INC{"cf.pm"};
239    
240     # don't, removes xs symbols, too
241 root 1.21 #Symbol::delete_package __PACKAGE__;
242 root 1.4
243     require cf;
244     };
245     warn $@ if $@;
246     $who->message ($@) if $@;
247 root 1.1 warn "reloaded\n";
248 root 1.3
249     $who->message ("reloaded");
250     } else {
251     $who->message ("Intruder Alert!");
252 root 1.1 }
253     };
254    
255 root 1.8 #############################################################################
256 root 1.15 # extcmd framework, basically convert ext <id> <pkg> arg1 args
257     # into pkg::->on_extcmd_arg1 (...) while shortcutting a few
258    
259     sub on_extcmd {
260     my ($pl, $buf) = @_;
261    
262 root 1.16 my ($type) = $buf =~ s/^(\S+) // ? $1 : "";
263 root 1.15
264 root 1.16 $extcmd{$type}[0]->($pl, $buf)
265     if $extcmd{$type};
266 root 1.15 }
267    
268     #############################################################################
269 root 1.8 # load/save/clean perl data associated with a map
270    
271 root 1.7 *on_mapclean = sub {
272 root 1.13 my ($map) = @_;
273 root 1.7
274     my $path = $map->tmpname;
275     defined $path or return;
276    
277     unlink "$path.cfperl";
278     };
279    
280 root 1.6 *on_mapin =
281     *on_mapload = sub {
282 root 1.13 my ($map) = @_;
283 root 1.6
284     my $path = $map->tmpname;
285     $path = $map->path unless defined $path;
286    
287     open my $fh, "<:raw", "$path.cfperl"
288     or return; # no perl data
289    
290     my $data = Storable::thaw do { local $/; <$fh> };
291    
292     $data->{version} <= 1
293     or return; # too new
294    
295     $map->_set_obs ($data->{obs});
296     };
297    
298     *on_mapout = sub {
299 root 1.13 my ($map) = @_;
300 root 1.6
301     my $path = $map->tmpname;
302     $path = $map->path unless defined $path;
303    
304     my $obs = $map->_get_obs;
305    
306     if (defined $obs) {
307     open my $fh, ">:raw", "$path.cfperl"
308     or die "$path.cfperl: $!";
309    
310 root 1.8 stat $path;
311    
312     print $fh Storable::nfreeze {
313     size => (stat _)[7],
314     time => (stat _)[9],
315     version => 1,
316     obs => $obs,
317     };
318    
319     chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
320     } else {
321     unlink "$path.cfperl";
322     }
323     };
324    
325     #############################################################################
326     # load/save perl data associated with player->ob objects
327    
328     *on_player_load = sub {
329 root 1.13 my ($ob, $path) = @_;
330 root 1.8
331 root 1.11 for my $o ($ob, $ob->inv) {
332     if (my $value = $o->get_ob_key_value ("_perl_data")) {
333     $o->set_ob_key_value ("_perl_data");
334    
335     %$o = %{ Storable::thaw pack "H*", $value };
336     }
337     }
338 root 1.8 };
339    
340     *on_player_save = sub {
341 root 1.13 my ($ob, $path) = @_;
342 root 1.8
343 root 1.11 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
344     for grep %$_, $ob, $ob->inv;
345 root 1.6 };
346    
347 root 1.22 #############################################################################
348     # core extensions - in perl
349    
350 root 1.23 =item cf::player::exists $login
351    
352     Returns true when the given account exists.
353    
354     =cut
355    
356     sub cf::player::exists($) {
357     cf::player::find $_[0]
358     or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
359     }
360    
361 root 1.22 # rough implementation of a future "reply" method that works
362     # with dialog boxes.
363 root 1.23 sub cf::object::player::reply($$$;$) {
364     my ($self, $npc, $msg, $flags) = @_;
365    
366     $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
367 root 1.22
368 root 1.24 if ($self->{record_replies}) {
369     push @{ $self->{record_replies} }, [$npc, $msg, $flags];
370     } else {
371     $msg = $npc->name . " says: $msg" if $npc;
372     $self->message ($msg, $flags);
373     }
374 root 1.22 }
375    
376     #############################################################################
377 root 1.23 # map scripting support
378    
379     our $safe = new Safe "ext";
380     our $safe_hole = new Safe::Hole;
381    
382     $SIG{FPE} = 'IGNORE';
383    
384     $safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
385    
386 root 1.25 # here we export the classes and methods available to script code
387    
388     for (
389     ["cf::object" => qw(contr)],
390     ["cf::object::player" => qw(player)],
391     ["cf::player" => qw(peaceful)],
392     ) {
393     no strict 'refs';
394     my ($pkg, @funs) = @$_;
395     *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
396     for @funs;
397     }
398 root 1.23
399     sub safe_eval($;@) {
400     my ($code, %vars) = @_;
401    
402     my $qcode = $code;
403     $qcode =~ s/"/‟/g; # not allowed in #line filenames
404     $qcode =~ s/\n/\\n/g;
405    
406     local $_;
407     local @ext::cf::_safe_eval_args = values %vars;
408    
409 root 1.25 $code =
410 root 1.23 "do {\n"
411     . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
412     . "#line 0 \"{$qcode}\"\n"
413     . $code
414     . "\n}"
415 root 1.25 ;
416    
417     sub_generation_inc;
418     my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code);
419     sub_generation_inc;
420    
421     wantarray ? @res : $res[0]
422 root 1.23 }
423    
424     sub register_script_function {
425     my ($fun, $cb) = @_;
426    
427     no strict 'refs';
428     *{"ext::$fun"} = $safe_hole->wrap ($cb);
429     }
430    
431     #############################################################################
432 root 1.22 # initialisation
433    
434 root 1.6 register "<global>", __PACKAGE__;
435    
436 root 1.17 unshift @INC, maps_directory "perl";
437    
438 root 1.1 load_extensions;
439    
440     1
441