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.56 by root, Wed Aug 30 08:28:33 2006 UTC vs.
Revision 1.107 by root, Sun Dec 31 18:10:40 2006 UTC

1package cf; 1package cf;
2
3use utf8;
4use strict;
2 5
3use Symbol; 6use Symbol;
4use List::Util; 7use List::Util;
5use Storable; 8use Storable;
6use Opcode; 9use Opcode;
7use Safe; 10use Safe;
8use Safe::Hole; 11use Safe::Hole;
9 12
13use Coro 3.3;
14use Coro::Event;
15use Coro::Timer;
16use Coro::Signal;
17use Coro::Semaphore;
18use Coro::AIO;
19
20use Fcntl;
21use IO::AIO 2.31 ();
22use YAML::Syck ();
10use Time::HiRes; 23use Time::HiRes;
11use Event; 24
12$Event::Eval = 1; # no idea why this is required, but it is 25use Event; $Event::Eval = 1; # no idea why this is required, but it is
13 26
14use strict; 27# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
28$YAML::Syck::ImplicitUnicode = 1;
15 29
16_reload_1; 30$Coro::main->prio (2); # run main coroutine ("the server") with very high priority
17 31
32sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
33
18our %COMMAND = (); 34our %COMMAND = ();
35our %COMMAND_TIME = ();
36our %EXTCMD = ();
37
19our @EVENT; 38our @EVENT;
20our %PROP_TYPE; 39our $LIBDIR = datadir . "/ext";
21our %PROP_IDX;
22our $LIBDIR = maps_directory "perl";
23 40
24our $TICK = MAX_TIME * 1e-6; 41our $TICK = MAX_TIME * 1e-6;
25our $TICK_WATCHER; 42our $TICK_WATCHER;
26our $NEXT_TICK; 43our $NEXT_TICK;
44our $NOW;
45
46our %CFG;
47
48our $UPTIME; $UPTIME ||= time;
49our $RUNTIME;
50
51our %MAP; # all maps
52our $LINK_MAP; # the special {link} map
53our $FREEZE;
54
55binmode STDOUT;
56binmode STDERR;
57
58# read virtual server time, if available
59unless ($RUNTIME || !-e cf::localdir . "/runtime") {
60 open my $fh, "<", cf::localdir . "/runtime"
61 or die "unable to read runtime file: $!";
62 $RUNTIME = <$fh> + 0.;
63}
64
65mkdir cf::localdir;
66mkdir cf::localdir . "/" . cf::playerdir;
67mkdir cf::localdir . "/" . cf::tmpdir;
68mkdir cf::localdir . "/" . cf::uniquedir;
69
70our %EXT_CORO;
71
72#############################################################################
73
74=head2 GLOBAL VARIABLES
75
76=over 4
77
78=item $cf::UPTIME
79
80The timestamp of the server start (so not actually an uptime).
81
82=item $cf::RUNTIME
83
84The time this server has run, starts at 0 and is increased by $cf::TICK on
85every server tick.
86
87=item $cf::LIBDIR
88
89The perl library directory, where extensions and cf-specific modules can
90be found. It will be added to C<@INC> automatically.
91
92=item $cf::NOW
93
94The time of the last (current) server tick.
95
96=item $cf::TICK
97
98The interval between server ticks, in seconds.
99
100=item %cf::CFG
101
102Configuration for the server, loaded from C</etc/crossfire/config>, or
103from wherever your confdir points to.
104
105=back
106
107=cut
27 108
28BEGIN { 109BEGIN {
29 *CORE::GLOBAL::warn = sub { 110 *CORE::GLOBAL::warn = sub {
30 my $msg = join "", @_; 111 my $msg = join "", @_;
112 utf8::encode $msg;
113
31 $msg .= "\n" 114 $msg .= "\n"
32 unless $msg =~ /\n$/; 115 unless $msg =~ /\n$/;
33 116
34 print STDERR "cfperl: $msg";
35 LOG llevError, "cfperl: $msg"; 117 LOG llevError, "cfperl: $msg";
36 }; 118 };
37} 119}
38 120
39my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply! 121@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
40 122@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
41# generate property mutators 123@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
42sub prop_gen { 124@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
43 my ($prefix, $class) = @_; 125@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
44
45 no strict 'refs';
46
47 for my $prop (keys %PROP_TYPE) {
48 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
49 my $sub = lc $1;
50
51 my $type = $PROP_TYPE{$prop};
52 my $idx = $PROP_IDX {$prop};
53
54 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
55 $_[0]->get_property ($type, $idx)
56 };
57
58 *{"$class\::set_$sub"} = sub {
59 $_[0]->set_property ($type, $idx, $_[1]);
60 } unless $ignore_set{$prop};
61 }
62}
63
64# auto-generate most of the API
65
66prop_gen OBJECT_PROP => "cf::object";
67# CFAPI_OBJECT_ANIMATION?
68prop_gen PLAYER_PROP => "cf::object::player";
69
70prop_gen MAP_PROP => "cf::map";
71prop_gen ARCH_PROP => "cf::arch";
72
73@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 126@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
74 127
75# we bless all objects into (empty) derived classes to force a method lookup 128# we bless all objects into (empty) derived classes to force a method lookup
76# within the Safe compartment. 129# within the Safe compartment.
77for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) { 130for my $pkg (qw(
131 cf::global cf::attachable
132 cf::object cf::object::player
133 cf::client cf::player
134 cf::arch cf::living
135 cf::map cf::party cf::region
136)) {
78 no strict 'refs'; 137 no strict 'refs';
79 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 138 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
80} 139}
81 140
82$Event::DIED = sub { 141$Event::DIED = sub {
84}; 143};
85 144
86my %ext_pkg; 145my %ext_pkg;
87my @exts; 146my @exts;
88my @hook; 147my @hook;
89my %command;
90my %extcmd;
91 148
92############################################################################# 149=head2 UTILITY FUNCTIONS
93# utility functions 150
151=over 4
152
153=cut
94 154
95use JSON::Syck (); # TODO# replace by JSON::PC once working 155use JSON::Syck (); # TODO# replace by JSON::PC once working
156
157=item $ref = cf::from_json $json
158
159Converts a JSON string into the corresponding perl data structure.
160
161=cut
96 162
97sub from_json($) { 163sub from_json($) {
98 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs 164 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
99 JSON::Syck::Load $_[0] 165 JSON::Syck::Load $_[0]
100} 166}
101 167
168=item $json = cf::to_json $ref
169
170Converts a perl data structure into its JSON representation.
171
172=cut
173
102sub to_json($) { 174sub to_json($) {
103 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 175 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
104 JSON::Syck::Dump $_[0] 176 JSON::Syck::Dump $_[0]
105} 177}
106 178
179=item cf::sync_job { BLOCK }
180
181The design of crossfire+ requires that the main coro ($Coro::main) is
182always able to handle events or runnable, as crossfire+ is only partly
183reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.
184
185If it must be done, put the blocking parts into C<sync_job>. This will run
186the given BLOCK in another coroutine while waiting for the result. The
187server will be frozen during this time, so the block should either finish
188fast or be very important.
189
190=cut
191
192sub sync_job(&) {
193 my ($job) = @_;
194
195 my $busy = 1;
196 my @res;
197
198 # TODO: use suspend/resume instead
199 local $FREEZE = 1;
200
201 my $coro = Coro::async {
202 @res = eval { $job->() };
203 warn $@ if $@;
204 undef $busy;
205 };
206
207 if ($Coro::current == $Coro::main) {
208 $coro->prio (Coro::PRIO_MAX);
209 while ($busy) {
210 Coro::cede_notself;
211 Event::one_event unless Coro::nready;
212 }
213 } else {
214 $coro->join;
215 }
216
217 wantarray ? @res : $res[0]
218}
219
220=item $coro = cf::coro { BLOCK }
221
222Creates and returns a new coro. This coro is automcatially being canceled
223when the extension calling this is being unloaded.
224
225=cut
226
227sub coro(&) {
228 my $cb = shift;
229
230 my $coro; $coro = async {
231 eval {
232 $cb->();
233 };
234 warn $@ if $@;
235 };
236
237 $coro->on_destroy (sub {
238 delete $EXT_CORO{$coro+0};
239 });
240 $EXT_CORO{$coro+0} = $coro;
241
242 $coro
243}
244
245=back
246
247=cut
248
107############################################################################# 249#############################################################################
108# "new" plug-in system
109 250
110=head3 EVENTS AND OBJECT ATTACHMENTS 251=head2 ATTACHABLE OBJECTS
252
253Many objects in crossfire are so-called attachable objects. That means you can
254attach callbacks/event handlers (a collection of which is called an "attachment")
255to it. All such attachable objects support the following methods.
256
257In the following description, CLASS can be any of C<global>, C<object>
258C<player>, C<client> or C<map> (i.e. the attachable objects in
259crossfire+).
111 260
112=over 4 261=over 4
113 262
114=item $object->attach ($attachment, key => $value...)
115
116=item $object->detach ($attachment)
117
118Attach/detach a pre-registered attachment to an object.
119
120=item $player->attach ($attachment, key => $value...)
121
122=item $player->detach ($attachment)
123
124Attach/detach a pre-registered attachment to a player.
125
126=item $map->attach ($attachment, key => $value...) 263=item $attachable->attach ($attachment, key => $value...)
127 264
128=item $map->detach ($attachment) 265=item $attachable->detach ($attachment)
129 266
130Attach/detach a pre-registered attachment to a map. 267Attach/detach a pre-registered attachment to a specific object and give it
268the specified key/value pairs as arguments.
131 269
132=item $bool = $object->attached ($name) 270Example, attach a minesweeper attachment to the given object, making it a
27110x10 minesweeper game:
133 272
134=item $bool = $player->attached ($name) 273 $obj->attach (minesweeper => width => 10, height => 10);
135 274
136=item $bool = $map->attached ($name) 275=item $bool = $attachable->attached ($name)
137 276
138Checks wether the named attachment is currently attached to the object. 277Checks wether the named attachment is currently attached to the object.
139 278
140=item cf::attach_global ... 279=item cf::CLASS->attach ...
141 280
142Attach handlers for global events. 281=item cf::CLASS->detach ...
143 282
144This and all following C<attach_*>-functions expect any number of the 283Define an anonymous attachment and attach it to all objects of the given
145following handler/hook descriptions: 284CLASS. See the next function for an explanation of its arguments.
285
286You can attach to global events by using the C<cf::global> class.
287
288Example, log all player logins:
289
290 cf::player->attach (
291 on_login => sub {
292 my ($pl) = @_;
293 ...
294 },
295 );
296
297Example, attach to the jeweler skill:
298
299 cf::object->attach (
300 type => cf::SKILL,
301 subtype => cf::SK_JEWELER,
302 on_use_skill => sub {
303 my ($sk, $ob, $part, $dir, $msg) = @_;
304 ...
305 },
306 );
307
308=item cf::CLASS::attachment $name, ...
309
310Register an attachment by C<$name> through which attachable objects of the
311given CLASS can refer to this attachment.
312
313Some classes such as crossfire maps and objects can specify attachments
314that are attached at load/instantiate time, thus the need for a name.
315
316These calls expect any number of the following handler/hook descriptions:
146 317
147=over 4 318=over 4
148 319
149=item prio => $number 320=item prio => $number
150 321
152by another C<prio> setting). Lower priority handlers get executed 323by another C<prio> setting). Lower priority handlers get executed
153earlier. The default priority is C<0>, and many built-in handlers are 324earlier. The default priority is C<0>, and many built-in handlers are
154registered at priority C<-1000>, so lower priorities should not be used 325registered at priority C<-1000>, so lower priorities should not be used
155unless you know what you are doing. 326unless you know what you are doing.
156 327
328=item type => $type
329
330(Only for C<< cf::object->attach >> calls), limits the attachment to the
331given type of objects only (the additional parameter C<subtype> can be
332used to further limit to the given subtype).
333
157=item on_I<event> => \&cb 334=item on_I<event> => \&cb
158 335
159Call the given code reference whenever the named event happens (event is 336Call the given code reference whenever the named event happens (event is
160something like C<instantiate>, C<apply>, C<use_skill> and so on, and which 337something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
161handlers are recognised generally depends on the type of object these 338handlers are recognised generally depends on the type of object these
170package and register them. Only handlers for eevents supported by the 347package and register them. Only handlers for eevents supported by the
171object/class are recognised. 348object/class are recognised.
172 349
173=back 350=back
174 351
175=item cf::attach_to_type $object_type, $subtype, ... 352Example, define an attachment called "sockpuppet" that calls the given
353event handler when a monster attacks:
176 354
177Attach handlers for a specific object type (e.g. TRANSPORT) and 355 cf::object::attachment sockpuppet =>
178subtype. If C<$subtype> is zero or undef, matches all objects of the given 356 on_skill_attack => sub {
179type. 357 my ($self, $victim) = @_;
180 358 ...
181=item cf::attach_to_objects ...
182
183Attach handlers to all objects. Do not use this except for debugging or
184very rare events, as handlers are (obviously) called for I<all> objects in
185the game.
186
187=item cf::attach_to_players ...
188
189Attach handlers to all players.
190
191=item cf::attach_to_maps ...
192
193Attach handlers to all maps.
194
195=item cf:register_attachment $name, ...
196
197Register an attachment by name through which objects can refer to this
198attachment.
199
200=item cf:register_player_attachment $name, ...
201
202Register an attachment by name through which players can refer to this
203attachment.
204
205=item cf:register_map_attachment $name, ...
206
207Register an attachment by name through which maps can refer to this
208attachment.
209
210=cut
211
212# the following variables are defined in .xs and must not be re-created
213our @CB_GLOBAL = (); # registry for all global events
214our @CB_OBJECT = (); # all objects (should not be used except in emergency)
215our @CB_PLAYER = ();
216our @CB_TYPE = (); # registry for type (cf-object class) based events
217our @CB_MAP = ();
218
219my %attachment;
220
221sub _attach_cb($\%$$$) {
222 my ($registry, $undo, $event, $prio, $cb) = @_;
223
224 use sort 'stable';
225
226 $cb = [$prio, $cb];
227
228 @{$registry->[$event]} = sort
229 { $a->[0] cmp $b->[0] }
230 @{$registry->[$event] || []}, $cb;
231
232 push @{$undo->{cb}}, [$event, $cb];
233}
234
235# attach handles attaching event callbacks
236# the only thing the caller has to do is pass the correct
237# registry (== where the callback attaches to).
238sub _attach(\@$@) {
239 my ($registry, $klass, @arg) = @_;
240
241 my $prio = 0;
242
243 my %undo = (
244 registry => $registry,
245 cb => [],
246 );
247
248 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
249
250 while (@arg) {
251 my $type = shift @arg;
252
253 if ($type eq "prio") {
254 $prio = shift @arg;
255
256 } elsif ($type eq "package") {
257 my $pkg = shift @arg;
258
259 while (my ($name, $id) = each %cb_id) {
260 if (my $cb = $pkg->can ($name)) {
261 _attach_cb $registry, %undo, $id, $prio, $cb;
262 }
263 } 359 }
264
265 } elsif (exists $cb_id{$type}) {
266 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg;
267
268 } elsif (ref $type) {
269 warn "attaching objects not supported, ignoring.\n";
270
271 } else {
272 shift @arg;
273 warn "attach argument '$type' not supported, ignoring.\n";
274 }
275 }
276
277 \%undo
278}
279
280sub _attach_attachment {
281 my ($obj, $name, %arg) = @_;
282
283 return if exists $obj->{_attachment}{$name};
284
285 my $res;
286
287 if (my $attach = $attachment{$name}) {
288 my $registry = $obj->registry;
289
290 for (@$attach) {
291 my ($klass, @attach) = @$_;
292 $res = _attach @$registry, $klass, @attach;
293 }
294
295 $obj->{$name} = \%arg;
296 } else {
297 warn "object uses attachment '$name' that is not available, postponing.\n";
298 }
299
300 $obj->{_attachment}{$name} = undef;
301
302 $res->{attachment} = $name;
303 $res
304}
305
306*cf::object::attach =
307*cf::player::attach =
308*cf::map::attach = sub {
309 my ($obj, $name, %arg) = @_;
310
311 _attach_attachment $obj, $name, %arg;
312};
313
314# all those should be optimised
315*cf::object::detach =
316*cf::player::detach =
317*cf::map::detach = sub {
318 my ($obj, $name) = @_;
319
320 delete $obj->{_attachment}{$name};
321 reattach ($obj);
322};
323
324*cf::object::attached =
325*cf::player::attached =
326*cf::map::attached = sub {
327 my ($obj, $name) = @_;
328
329 exists $obj->{_attachment}{$name}
330};
331
332sub attach_global {
333 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
334}
335
336sub attach_to_type {
337 my $type = shift;
338 my $subtype = shift;
339
340 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
341}
342
343sub attach_to_objects {
344 _attach @CB_OBJECT, KLASS_OBJECT, @_
345}
346
347sub attach_to_players {
348 _attach @CB_PLAYER, KLASS_PLAYER, @_
349}
350
351sub attach_to_maps {
352 _attach @CB_MAP, KLASS_MAP, @_
353}
354
355sub register_attachment {
356 my $name = shift;
357
358 $attachment{$name} = [[KLASS_OBJECT, @_]];
359}
360
361sub register_player_attachment {
362 my $name = shift;
363
364 $attachment{$name} = [[KLASS_PLAYER, @_]];
365}
366
367sub register_map_attachment {
368 my $name = shift;
369
370 $attachment{$name} = [[KLASS_MAP, @_]];
371}
372
373our $override;
374our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
375
376sub override {
377 $override = 1;
378 @invoke_results = ();
379}
380
381sub do_invoke {
382 my $event = shift;
383 my $callbacks = shift;
384
385 @invoke_results = ();
386
387 local $override;
388
389 for (@$callbacks) {
390 eval { &{$_->[1]} };
391
392 if ($@) {
393 warn "$@";
394 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n";
395 override;
396 }
397
398 return 1 if $override;
399 }
400
401 0 360 }
402}
403 361
404=item $bool = cf::invoke EVENT_GLOBAL_XXX, ... 362=item $attachable->valid
405
406=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
407
408=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
409
410=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
411
412Generate a global/object/player/map-specific event with the given arguments.
413
414This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
415removed in future versions), and there is no public API to access override
416results (if you must, access C<@cf::invoke_results> directly).
417
418=back
419
420=head2 methods valid for all pointers
421
422=over 4
423
424=item $object->valid
425
426=item $player->valid
427
428=item $map->valid
429 363
430Just because you have a perl object does not mean that the corresponding 364Just because you have a perl object does not mean that the corresponding
431C-level object still exists. If you try to access an object that has no 365C-level object still exists. If you try to access an object that has no
432valid C counterpart anymore you get an exception at runtime. This method 366valid C counterpart anymore you get an exception at runtime. This method
433can be used to test for existence of the C object part without causing an 367can be used to test for existence of the C object part without causing an
434exception. 368exception.
435 369
370=cut
371
372# the following variables are defined in .xs and must not be re-created
373our @CB_GLOBAL = (); # registry for all global events
374our @CB_ATTACHABLE = (); # registry for all attachables
375our @CB_OBJECT = (); # all objects (should not be used except in emergency)
376our @CB_PLAYER = ();
377our @CB_CLIENT = ();
378our @CB_TYPE = (); # registry for type (cf-object class) based events
379our @CB_MAP = ();
380
381my %attachment;
382
383sub _attach_cb($$$$) {
384 my ($registry, $event, $prio, $cb) = @_;
385
386 use sort 'stable';
387
388 $cb = [$prio, $cb];
389
390 @{$registry->[$event]} = sort
391 { $a->[0] cmp $b->[0] }
392 @{$registry->[$event] || []}, $cb;
393}
394
395# hack
396my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
397
398# attach handles attaching event callbacks
399# the only thing the caller has to do is pass the correct
400# registry (== where the callback attaches to).
401sub _attach {
402 my ($registry, $klass, @arg) = @_;
403
404 my $object_type;
405 my $prio = 0;
406 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
407
408 #TODO: get rid of this hack
409 if ($attachable_klass{$klass}) {
410 %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
411 }
412
413 while (@arg) {
414 my $type = shift @arg;
415
416 if ($type eq "prio") {
417 $prio = shift @arg;
418
419 } elsif ($type eq "type") {
420 $object_type = shift @arg;
421 $registry = $CB_TYPE[$object_type] ||= [];
422
423 } elsif ($type eq "subtype") {
424 defined $object_type or Carp::croak "subtype specified without type";
425 my $object_subtype = shift @arg;
426 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= [];
427
428 } elsif ($type eq "package") {
429 my $pkg = shift @arg;
430
431 while (my ($name, $id) = each %cb_id) {
432 if (my $cb = $pkg->can ($name)) {
433 _attach_cb $registry, $id, $prio, $cb;
434 }
435 }
436
437 } elsif (exists $cb_id{$type}) {
438 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
439
440 } elsif (ref $type) {
441 warn "attaching objects not supported, ignoring.\n";
442
443 } else {
444 shift @arg;
445 warn "attach argument '$type' not supported, ignoring.\n";
446 }
447 }
448}
449
450sub _object_attach {
451 my ($obj, $name, %arg) = @_;
452
453 return if exists $obj->{_attachment}{$name};
454
455 if (my $attach = $attachment{$name}) {
456 my $registry = $obj->registry;
457
458 for (@$attach) {
459 my ($klass, @attach) = @$_;
460 _attach $registry, $klass, @attach;
461 }
462
463 $obj->{$name} = \%arg;
464 } else {
465 warn "object uses attachment '$name' that is not available, postponing.\n";
466 }
467
468 $obj->{_attachment}{$name} = undef;
469}
470
471sub cf::attachable::attach {
472 if (ref $_[0]) {
473 _object_attach @_;
474 } else {
475 _attach shift->_attach_registry, @_;
476 }
477};
478
479# all those should be optimised
480sub cf::attachable::detach {
481 my ($obj, $name) = @_;
482
483 if (ref $obj) {
484 delete $obj->{_attachment}{$name};
485 reattach ($obj);
486 } else {
487 Carp::croak "cannot, currently, detach class attachments";
488 }
489};
490
491sub cf::attachable::attached {
492 my ($obj, $name) = @_;
493
494 exists $obj->{_attachment}{$name}
495}
496
497for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
498 eval "#line " . __LINE__ . " 'cf.pm'
499 sub cf::\L$klass\E::_attach_registry {
500 (\\\@CB_$klass, KLASS_$klass)
501 }
502
503 sub cf::\L$klass\E::attachment {
504 my \$name = shift;
505
506 \$attachment{\$name} = [[KLASS_$klass, \@_]];
507 }
508 ";
509 die if $@;
510}
511
512our $override;
513our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
514
515sub override {
516 $override = 1;
517 @invoke_results = ();
518}
519
520sub do_invoke {
521 my $event = shift;
522 my $callbacks = shift;
523
524 @invoke_results = ();
525
526 local $override;
527
528 for (@$callbacks) {
529 eval { &{$_->[1]} };
530
531 if ($@) {
532 warn "$@";
533 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
534 override;
535 }
536
537 return 1 if $override;
538 }
539
540 0
541}
542
543=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)
544
545=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
546
547Generate an object-specific event with the given arguments.
548
549This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
550removed in future versions), and there is no public API to access override
551results (if you must, access C<@cf::invoke_results> directly).
552
436=back 553=back
437 554
438=cut 555=cut
439
440*cf::object::valid =
441*cf::player::valid =
442*cf::map::valid = \&cf::_valid;
443 556
444############################################################################# 557#############################################################################
445# object support 558# object support
446 559
447sub instantiate {
448 my ($obj, $data) = @_;
449
450 $data = from_json $data;
451
452 for (@$data) {
453 my ($name, $args) = @$_;
454
455 $obj->attach ($name, %{$args || {} });
456 }
457}
458
459# basically do the same as instantiate, without calling instantiate
460sub reattach { 560sub reattach {
561 # basically do the same as instantiate, without calling instantiate
461 my ($obj) = @_; 562 my ($obj) = @_;
563
462 my $registry = $obj->registry; 564 my $registry = $obj->registry;
463 565
464 @$registry = (); 566 @$registry = ();
465 567
466 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} }; 568 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
467 569
468 for my $name (keys %{ $obj->{_attachment} || {} }) { 570 for my $name (keys %{ $obj->{_attachment} || {} }) {
469 if (my $attach = $attachment{$name}) { 571 if (my $attach = $attachment{$name}) {
470 for (@$attach) { 572 for (@$attach) {
471 my ($klass, @attach) = @$_; 573 my ($klass, @attach) = @$_;
472 _attach @$registry, $klass, @attach; 574 _attach $registry, $klass, @attach;
473 } 575 }
474 } else { 576 } else {
475 warn "object uses attachment '$name' that is not available, postponing.\n"; 577 warn "object uses attachment '$name' that is not available, postponing.\n";
476 } 578 }
477 } 579 }
478} 580}
479 581
480sub object_freezer_save { 582cf::attachable->attach (
481 my ($filename, $objs) = @_;
482
483 if (@$objs) {
484 open my $fh, ">:raw", "$filename.pst~";
485 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
486 close $fh;
487 chmod SAVE_MODE, "$filename.pst~";
488 rename "$filename.pst~", "$filename.pst";
489 } else {
490 unlink "$filename.pst";
491 }
492
493 chmod SAVE_MODE, "$filename~";
494 rename "$filename~", $filename;
495}
496
497sub object_thawer_load {
498 my ($filename) = @_;
499
500 open my $fh, "<:raw:perlio", "$filename.pst"
501 or return;
502
503 eval { local $/; (Storable::thaw <$fh>)->{objs} }
504}
505
506attach_to_objects
507 prio => -1000000, 583 prio => -1000000,
584 on_instantiate => sub {
585 my ($obj, $data) = @_;
586
587 $data = from_json $data;
588
589 for (@$data) {
590 my ($name, $args) = @$_;
591
592 $obj->attach ($name, %{$args || {} });
593 }
594 },
595 on_reattach => \&reattach,
508 on_clone => sub { 596 on_clone => sub {
509 my ($src, $dst) = @_; 597 my ($src, $dst) = @_;
510 598
511 @{$dst->registry} = @{$src->registry}; 599 @{$dst->registry} = @{$src->registry};
512 600
513 %$dst = %$src; 601 %$dst = %$src;
514 602
515 %{$dst->{_attachment}} = %{$src->{_attachment}} 603 %{$dst->{_attachment}} = %{$src->{_attachment}}
516 if exists $src->{_attachment}; 604 if exists $src->{_attachment};
517 }, 605 },
518; 606);
607
608sub object_freezer_save {
609 my ($filename, $rdata, $objs) = @_;
610
611 sync_job {
612 if (length $$rdata) {
613 warn sprintf "saving %s (%d,%d)\n",
614 $filename, length $$rdata, scalar @$objs;
615
616 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
617 chmod SAVE_MODE, $fh;
618 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
619 aio_fsync $fh;
620 close $fh;
621
622 if (@$objs) {
623 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
624 chmod SAVE_MODE, $fh;
625 my $data = Storable::nfreeze { version => 1, objs => $objs };
626 aio_write $fh, 0, (length $data), $data, 0;
627 aio_fsync $fh;
628 close $fh;
629 aio_rename "$filename.pst~", "$filename.pst";
630 }
631 } else {
632 aio_unlink "$filename.pst";
633 }
634
635 aio_rename "$filename~", $filename;
636 } else {
637 warn "FATAL: $filename~: $!\n";
638 }
639 } else {
640 aio_unlink $filename;
641 aio_unlink "$filename.pst";
642 }
643 }
644}
645
646sub object_freezer_as_string {
647 my ($rdata, $objs) = @_;
648
649 use Data::Dumper;
650
651 $$rdata . Dumper $objs
652}
653
654sub object_thawer_load {
655 my ($filename) = @_;
656
657 my ($data, $av);
658
659 (aio_load $filename, $data) >= 0
660 or return;
661
662 unless (aio_stat "$filename.pst") {
663 (aio_load "$filename.pst", $av) >= 0
664 or return;
665 $av = eval { (Storable::thaw <$av>)->{objs} };
666 }
667
668 return ($data, $av);
669}
519 670
520############################################################################# 671#############################################################################
521# old plug-in events 672# command handling &c
522 673
523sub inject_event { 674=item cf::register_command $name => \&callback($ob,$args);
524 my $extension = shift;
525 my $event_code = shift;
526 675
527 my $cb = $hook[$event_code]{$extension} 676Register a callback for execution when the client sends the user command
528 or return; 677$name.
529 678
530 &$cb 679=cut
531}
532
533sub inject_global_event {
534 my $event = shift;
535
536 my $cb = $hook[$event]
537 or return;
538
539 List::Util::max map &$_, values %$cb
540}
541
542sub inject_command {
543 my ($name, $obj, $params) = @_;
544
545 for my $cmd (@{ $command{$name} }) {
546 $cmd->[1]->($obj, $params);
547 }
548
549 -1
550}
551 680
552sub register_command { 681sub register_command {
553 my ($name, $time, $cb) = @_; 682 my ($name, $cb) = @_;
554 683
555 my $caller = caller; 684 my $caller = caller;
556 #warn "registering command '$name/$time' to '$caller'"; 685 #warn "registering command '$name/$time' to '$caller'";
557 686
558 push @{ $command{$name} }, [$time, $cb, $caller]; 687 push @{ $COMMAND{$name} }, [$caller, $cb];
559 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
560} 688}
689
690=item cf::register_extcmd $name => \&callback($pl,$packet);
691
692Register a callbackf ro execution when the client sends an extcmd packet.
693
694If the callback returns something, it is sent back as if reply was being
695called.
696
697=cut
561 698
562sub register_extcmd { 699sub register_extcmd {
563 my ($name, $cb) = @_; 700 my ($name, $cb) = @_;
564 701
565 my $caller = caller; 702 my $caller = caller;
566 #warn "registering extcmd '$name' to '$caller'"; 703 #warn "registering extcmd '$name' to '$caller'";
567 704
568 $extcmd{$name} = [$cb, $caller]; 705 $EXTCMD{$name} = [$cb, $caller];
569} 706}
707
708cf::player->attach (
709 on_command => sub {
710 my ($pl, $name, $params) = @_;
711
712 my $cb = $COMMAND{$name}
713 or return;
714
715 for my $cmd (@$cb) {
716 $cmd->[1]->($pl->ob, $params);
717 }
718
719 cf::override;
720 },
721 on_extcmd => sub {
722 my ($pl, $buf) = @_;
723
724 my $msg = eval { from_json $buf };
725
726 if (ref $msg) {
727 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
728 if (my %reply = $cb->[0]->($pl, $msg)) {
729 $pl->ext_reply ($msg->{msgid}, %reply);
730 }
731 }
732 } else {
733 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
734 }
735
736 cf::override;
737 },
738);
570 739
571sub register { 740sub register {
572 my ($base, $pkg) = @_; 741 my ($base, $pkg) = @_;
573 742
574 #TODO 743 #TODO
593 . "#line 1 \"$path\"\n{\n" 762 . "#line 1 \"$path\"\n{\n"
594 . (do { local $/; <$fh> }) 763 . (do { local $/; <$fh> })
595 . "\n};\n1"; 764 . "\n};\n1";
596 765
597 eval $source 766 eval $source
598 or die "$path: $@"; 767 or die $@ ? "$path: $@\n"
768 : "extension disabled.\n";
599 769
600 push @exts, $pkg; 770 push @exts, $pkg;
601 $ext_pkg{$base} = $pkg; 771 $ext_pkg{$base} = $pkg;
602 772
603# no strict 'refs'; 773# no strict 'refs';
616# for my $idx (0 .. $#PLUGIN_EVENT) { 786# for my $idx (0 .. $#PLUGIN_EVENT) {
617# delete $hook[$idx]{$pkg}; 787# delete $hook[$idx]{$pkg};
618# } 788# }
619 789
620 # remove commands 790 # remove commands
621 for my $name (keys %command) { 791 for my $name (keys %COMMAND) {
622 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 792 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
623 793
624 if (@cb) { 794 if (@cb) {
625 $command{$name} = \@cb; 795 $COMMAND{$name} = \@cb;
626 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
627 } else { 796 } else {
628 delete $command{$name};
629 delete $COMMAND{"$name\000"}; 797 delete $COMMAND{$name};
630 } 798 }
631 } 799 }
632 800
633 # remove extcmds 801 # remove extcmds
634 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 802 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
635 delete $extcmd{$name}; 803 delete $EXTCMD{$name};
636 } 804 }
637 805
638 if (my $cb = $pkg->can ("unload")) { 806 if (my $cb = $pkg->can ("unload")) {
639 eval { 807 eval {
640 $cb->($pkg); 808 $cb->($pkg);
644 812
645 Symbol::delete_package $pkg; 813 Symbol::delete_package $pkg;
646} 814}
647 815
648sub load_extensions { 816sub load_extensions {
649 my $LIBDIR = maps_directory "perl";
650
651 for my $ext (<$LIBDIR/*.ext>) { 817 for my $ext (<$LIBDIR/*.ext>) {
652 next unless -r $ext; 818 next unless -r $ext;
653 eval { 819 eval {
654 load_extension $ext; 820 load_extension $ext;
655 1 821 1
656 } or warn "$ext not loaded: $@"; 822 } or warn "$ext not loaded: $@";
657 } 823 }
658} 824}
659 825
660sub _perl_reload(&) {
661 my ($msg) = @_;
662
663 $msg->("reloading...");
664
665 eval {
666 # 1. cancel all watchers
667 $_->cancel for Event::all_watchers;
668
669 # 2. unload all extensions
670 for (@exts) {
671 $msg->("unloading <$_>");
672 unload_extension $_;
673 }
674
675 # 3. unload all modules loaded from $LIBDIR
676 while (my ($k, $v) = each %INC) {
677 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
678
679 $msg->("removing <$k>");
680 delete $INC{$k};
681
682 $k =~ s/\.pm$//;
683 $k =~ s/\//::/g;
684
685 if (my $cb = $k->can ("unload_module")) {
686 $cb->();
687 }
688
689 Symbol::delete_package $k;
690 }
691
692 # 4. get rid of safe::, as good as possible
693 Symbol::delete_package "safe::$_"
694 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
695
696 # 5. remove register_script_function callbacks
697 # TODO
698
699 # 6. unload cf.pm "a bit"
700 delete $INC{"cf.pm"};
701
702 # don't, removes xs symbols, too,
703 # and global variables created in xs
704 #Symbol::delete_package __PACKAGE__;
705
706 # 7. reload cf.pm
707 $msg->("reloading cf.pm");
708 require cf;
709 };
710 $msg->($@) if $@;
711
712 $msg->("reloaded");
713};
714
715sub perl_reload() {
716 _perl_reload {
717 warn $_[0];
718 print "$_[0]\n";
719 };
720}
721
722register_command "perl-reload", 0, sub {
723 my ($who, $arg) = @_;
724
725 if ($who->flag (FLAG_WIZ)) {
726 _perl_reload {
727 warn $_[0];
728 $who->message ($_[0]);
729 };
730 }
731};
732
733#############################################################################
734# extcmd framework, basically convert ext <msg>
735# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
736
737attach_to_players
738 on_extcmd => sub {
739 my ($pl, $buf) = @_;
740
741 my $msg = eval { from_json $buf };
742
743 if (ref $msg) {
744 if (my $cb = $extcmd{$msg->{msgtype}}) {
745 if (my %reply = $cb->[0]->($pl, $msg)) {
746 $pl->ext_reply ($msg->{msgid}, %reply);
747 }
748 }
749 } else {
750 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
751 }
752
753 cf::override;
754 },
755;
756
757############################################################################# 826#############################################################################
758# load/save/clean perl data associated with a map 827# load/save/clean perl data associated with a map
759 828
760*cf::mapsupport::on_clean = sub { 829*cf::mapsupport::on_clean = sub {
761 my ($map) = @_; 830 my ($map) = @_;
764 defined $path or return; 833 defined $path or return;
765 834
766 unlink "$path.pst"; 835 unlink "$path.pst";
767}; 836};
768 837
769# old style persistent data, TODO: remove #d#
770*cf::mapsupport::on_swapin = sub {
771 my ($map) = @_;
772
773 my $path = $map->tmpname;
774 $path = $map->path unless defined $path;
775
776 warn "$path.cfperl\n";#d#
777
778 open my $fh, "<:raw", "$path.cfperl"
779 or return; # no perl data
780
781 my $data = Storable::thaw do { local $/; <$fh> };
782
783 $data->{version} <= 1
784 or return; # too new
785
786 $map->_set_obs ($data->{obs});
787 $map->invoke (EVENT_MAP_UPGRADE);
788};
789
790attach_to_maps prio => -10000, package => cf::mapsupport::; 838cf::map->attach (prio => -10000, package => cf::mapsupport::);
791 839
792############################################################################# 840#############################################################################
793# load/save perl data associated with player->ob objects 841# load/save perl data associated with player->ob objects
794 842
795sub all_objects(@) { 843sub all_objects(@) {
796 @_, map all_objects ($_->inv), @_ 844 @_, map all_objects ($_->inv), @_
797} 845}
798 846
799attach_to_players 847# TODO: compatibility cruft, remove when no longer needed
848cf::player->attach (
800 on_load => sub { 849 on_load => sub {
801 my ($pl, $path) = @_; 850 my ($pl, $path) = @_;
802 851
803 for my $o (all_objects $pl->ob) { 852 for my $o (all_objects $pl->ob) {
804 if (my $value = $o->get_ob_key_value ("_perl_data")) { 853 if (my $value = $o->get_ob_key_value ("_perl_data")) {
806 855
807 %$o = %{ Storable::thaw pack "H*", $value }; 856 %$o = %{ Storable::thaw pack "H*", $value };
808 } 857 }
809 } 858 }
810 }, 859 },
811; 860);
812 861
813############################################################################# 862#############################################################################
814# core extensions - in perl 863
864=head2 CORE EXTENSIONS
865
866Functions and methods that extend core crossfire objects.
867
868=head3 cf::player
869
870=over 4
815 871
816=item cf::player::exists $login 872=item cf::player::exists $login
817 873
818Returns true when the given account exists. 874Returns true when the given account exists.
819 875
822sub cf::player::exists($) { 878sub cf::player::exists($) {
823 cf::player::find $_[0] 879 cf::player::find $_[0]
824 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 880 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
825} 881}
826 882
883=item $player->ext_reply ($msgid, $msgtype, %msg)
884
885Sends an ext reply to the player.
886
887=cut
888
889sub cf::player::ext_reply($$$%) {
890 my ($self, $id, %msg) = @_;
891
892 $msg{msgid} = $id;
893
894 $self->send ("ext " . to_json \%msg);
895}
896
897=back
898
899=head3 cf::object::player
900
901=over 4
902
827=item $player->reply ($npc, $msg[, $flags]) 903=item $player_object->reply ($npc, $msg[, $flags])
828 904
829Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 905Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
830can be C<undef>. Does the right thing when the player is currently in a 906can be C<undef>. Does the right thing when the player is currently in a
831dialogue with the given NPC character. 907dialogue with the given NPC character.
832 908
833=cut 909=cut
834 910
835# rough implementation of a future "reply" method that works 911# rough implementation of a future "reply" method that works
836# with dialog boxes. 912# with dialog boxes.
913#TODO: the first argument must go, split into a $npc->reply_to ( method
837sub cf::object::player::reply($$$;$) { 914sub cf::object::player::reply($$$;$) {
838 my ($self, $npc, $msg, $flags) = @_; 915 my ($self, $npc, $msg, $flags) = @_;
839 916
840 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 917 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
841 918
845 $msg = $npc->name . " says: $msg" if $npc; 922 $msg = $npc->name . " says: $msg" if $npc;
846 $self->message ($msg, $flags); 923 $self->message ($msg, $flags);
847 } 924 }
848} 925}
849 926
850=item $player->ext_reply ($msgid, $msgtype, %msg) 927=item $player_object->may ("access")
851 928
852Sends an ext reply to the player. 929Returns wether the given player is authorized to access resource "access"
930(e.g. "command_wizcast").
853 931
854=cut 932=cut
855 933
856sub cf::player::ext_reply($$$%) { 934sub cf::object::player::may {
935 my ($self, $access) = @_;
936
937 $self->flag (cf::FLAG_WIZ) ||
938 (ref $cf::CFG{"may_$access"}
939 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
940 : $cf::CFG{"may_$access"})
941}
942
943=head3 cf::client
944
945=over 4
946
947=item $client->send_drawinfo ($text, $flags)
948
949Sends a drawinfo packet to the client. Circumvents output buffering so
950should not be used under normal circumstances.
951
952=cut
953
954sub cf::client::send_drawinfo {
955 my ($self, $text, $flags) = @_;
956
957 utf8::encode $text;
958 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text);
959}
960
961
962=item $success = $client->query ($flags, "text", \&cb)
963
964Queues a query to the client, calling the given callback with
965the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
966C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
967
968Queries can fail, so check the return code. Or don't, as queries will become
969reliable at some point in the future.
970
971=cut
972
973sub cf::client::query {
974 my ($self, $flags, $text, $cb) = @_;
975
976 return unless $self->state == ST_PLAYING
977 || $self->state == ST_SETUP
978 || $self->state == ST_CUSTOM;
979
980 $self->state (ST_CUSTOM);
981
982 utf8::encode $text;
983 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
984
985 $self->send_packet ($self->{query_queue}[0][0])
986 if @{ $self->{query_queue} } == 1;
987}
988
989cf::client->attach (
990 on_reply => sub {
991 my ($ns, $msg) = @_;
992
993 # this weird shuffling is so that direct followup queries
994 # get handled first
995 my $queue = delete $ns->{query_queue};
996
997 (shift @$queue)->[1]->($msg);
998
999 push @{ $ns->{query_queue} }, @$queue;
1000
1001 if (@{ $ns->{query_queue} } == @$queue) {
1002 if (@$queue) {
1003 $ns->send_packet ($ns->{query_queue}[0][0]);
1004 } else {
1005 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1006 }
1007 }
1008 },
1009);
1010
1011=item $client->coro (\&cb)
1012
1013Create a new coroutine, running the specified callback. The coroutine will
1014be automatically cancelled when the client gets destroyed (e.g. on logout,
1015or loss of connection).
1016
1017=cut
1018
1019sub cf::client::coro {
857 my ($self, $id, %msg) = @_; 1020 my ($self, $cb) = @_;
858 1021
859 $msg{msgid} = $id; 1022 my $coro; $coro = async {
1023 eval {
1024 $cb->();
1025 };
1026 warn $@ if $@;
1027 };
860 1028
861 $self->send ("ext " . to_json \%msg); 1029 $coro->on_destroy (sub {
862} 1030 delete $self->{_coro}{$coro+0};
1031 });
863 1032
864############################################################################# 1033 $self->{_coro}{$coro+0} = $coro;
865# map scripting support 1034
1035 $coro
1036}
1037
1038cf::client->attach (
1039 on_destroy => sub {
1040 my ($ns) = @_;
1041
1042 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
1043 },
1044);
1045
1046=back
1047
1048
1049=head2 SAFE SCRIPTING
1050
1051Functions that provide a safe environment to compile and execute
1052snippets of perl code without them endangering the safety of the server
1053itself. Looping constructs, I/O operators and other built-in functionality
1054is not available in the safe scripting environment, and the number of
1055functions and methods that can be called is greatly reduced.
1056
1057=cut
866 1058
867our $safe = new Safe "safe"; 1059our $safe = new Safe "safe";
868our $safe_hole = new Safe::Hole; 1060our $safe_hole = new Safe::Hole;
869 1061
870$SIG{FPE} = 'IGNORE'; 1062$SIG{FPE} = 'IGNORE';
871 1063
872$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 1064$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
873 1065
874# here we export the classes and methods available to script code 1066# here we export the classes and methods available to script code
875 1067
1068=pod
1069
1070The following fucntions and emthods are available within a safe environment:
1071
1072 cf::object contr pay_amount pay_player map
1073 cf::object::player player
1074 cf::player peaceful
1075 cf::map trigger
1076
1077=cut
1078
876for ( 1079for (
877 ["cf::object" => qw(contr pay_amount pay_player)], 1080 ["cf::object" => qw(contr pay_amount pay_player map)],
878 ["cf::object::player" => qw(player)], 1081 ["cf::object::player" => qw(player)],
879 ["cf::player" => qw(peaceful)], 1082 ["cf::player" => qw(peaceful)],
1083 ["cf::map" => qw(trigger)],
880) { 1084) {
881 no strict 'refs'; 1085 no strict 'refs';
882 my ($pkg, @funs) = @$_; 1086 my ($pkg, @funs) = @$_;
883 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 1087 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
884 for @funs; 1088 for @funs;
885} 1089}
1090
1091=over 4
1092
1093=item @retval = safe_eval $code, [var => value, ...]
1094
1095Compiled and executes the given perl code snippet. additional var/value
1096pairs result in temporary local (my) scalar variables of the given name
1097that are available in the code snippet. Example:
1098
1099 my $five = safe_eval '$first + $second', first => 1, second => 4;
1100
1101=cut
886 1102
887sub safe_eval($;@) { 1103sub safe_eval($;@) {
888 my ($code, %vars) = @_; 1104 my ($code, %vars) = @_;
889 1105
890 my $qcode = $code; 1106 my $qcode = $code;
913 } 1129 }
914 1130
915 wantarray ? @res : $res[0] 1131 wantarray ? @res : $res[0]
916} 1132}
917 1133
1134=item cf::register_script_function $function => $cb
1135
1136Register a function that can be called from within map/npc scripts. The
1137function should be reasonably secure and should be put into a package name
1138like the extension.
1139
1140Example: register a function that gets called whenever a map script calls
1141C<rent::overview>, as used by the C<rent> extension.
1142
1143 cf::register_script_function "rent::overview" => sub {
1144 ...
1145 };
1146
1147=cut
1148
918sub register_script_function { 1149sub register_script_function {
919 my ($fun, $cb) = @_; 1150 my ($fun, $cb) = @_;
920 1151
921 no strict 'refs'; 1152 no strict 'refs';
922 *{"safe::$fun"} = $safe_hole->wrap ($cb); 1153 *{"safe::$fun"} = $safe_hole->wrap ($cb);
923} 1154}
924 1155
1156=back
1157
1158=cut
1159
1160#############################################################################
1161
1162=head2 EXTENSION DATABASE SUPPORT
1163
1164Crossfire maintains a very simple database for extension use. It can
1165currently store anything that can be serialised using Storable, which
1166excludes objects.
1167
1168The parameter C<$family> should best start with the name of the extension
1169using it, it should be unique.
1170
1171=over 4
1172
1173=item $hashref = cf::db_get $family
1174
1175Return a hashref for use by the extension C<$family>, which can be
1176modified. After modifications, you have to call C<cf::db_dirty> or
1177C<cf::db_sync>.
1178
1179=item $value = cf::db_get $family => $key
1180
1181Returns a single value from the database
1182
1183=item cf::db_put $family => $hashref
1184
1185Stores the given family hashref into the database. Updates are delayed, if
1186you want the data to be synced to disk immediately, use C<cf::db_sync>.
1187
1188=item cf::db_put $family => $key => $value
1189
1190Stores the given C<$value> in the family hash. Updates are delayed, if you
1191want the data to be synced to disk immediately, use C<cf::db_sync>.
1192
1193=item cf::db_dirty
1194
1195Marks the database as dirty, to be updated at a later time.
1196
1197=item cf::db_sync
1198
1199Immediately write the database to disk I<if it is dirty>.
1200
1201=cut
1202
1203our $DB;
1204
1205{
1206 my $path = cf::localdir . "/database.pst";
1207
1208 sub db_load() {
1209 warn "loading database $path\n";#d# remove later
1210 $DB = stat $path ? Storable::retrieve $path : { };
1211 }
1212
1213 my $pid;
1214
1215 sub db_save() {
1216 warn "saving database $path\n";#d# remove later
1217 waitpid $pid, 0 if $pid;
1218 if (0 == ($pid = fork)) {
1219 $DB->{_meta}{version} = 1;
1220 Storable::nstore $DB, "$path~";
1221 rename "$path~", $path;
1222 cf::_exit 0 if defined $pid;
1223 }
1224 }
1225
1226 my $dirty;
1227
1228 sub db_sync() {
1229 db_save if $dirty;
1230 undef $dirty;
1231 }
1232
1233 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1234 db_sync;
1235 });
1236
1237 sub db_dirty() {
1238 $dirty = 1;
1239 $idle->start;
1240 }
1241
1242 sub db_get($;$) {
1243 @_ >= 2
1244 ? $DB->{$_[0]}{$_[1]}
1245 : ($DB->{$_[0]} ||= { })
1246 }
1247
1248 sub db_put($$;$) {
1249 if (@_ >= 3) {
1250 $DB->{$_[0]}{$_[1]} = $_[2];
1251 } else {
1252 $DB->{$_[0]} = $_[1];
1253 }
1254 db_dirty;
1255 }
1256
1257 cf::global->attach (
1258 prio => 10000,
1259 on_cleanup => sub {
1260 db_sync;
1261 },
1262 );
1263}
1264
925############################################################################# 1265#############################################################################
926# the server's main() 1266# the server's main()
927 1267
1268sub cfg_load {
1269 open my $fh, "<:utf8", cf::confdir . "/config"
1270 or return;
1271
1272 local $/;
1273 *CFG = YAML::Syck::Load <$fh>;
1274}
1275
928sub main { 1276sub main {
1277 cfg_load;
1278 db_load;
1279 load_extensions;
929 Event::loop; 1280 Event::loop;
930} 1281}
931 1282
932############################################################################# 1283#############################################################################
933# initialisation 1284# initialisation
934 1285
1286sub perl_reload() {
1287 # can/must only be called in main
1288 if ($Coro::current != $Coro::main) {
1289 warn "can only reload from main coroutine\n";
1290 return;
1291 }
1292
1293 warn "reloading...";
1294
1295 local $FREEZE = 1;
1296 cf::emergency_save;
1297
1298 eval {
1299 # if anything goes wrong in here, we should simply crash as we already saved
1300
1301 # cancel all watchers
1302 for (Event::all_watchers) {
1303 $_->cancel if $_->data & WF_AUTOCANCEL;
1304 }
1305
1306 # cancel all extension coros
1307 $_->cancel for values %EXT_CORO;
1308 %EXT_CORO = ();
1309
1310 # unload all extensions
1311 for (@exts) {
1312 warn "unloading <$_>";
1313 unload_extension $_;
1314 }
1315
1316 # unload all modules loaded from $LIBDIR
1317 while (my ($k, $v) = each %INC) {
1318 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1319
1320 warn "removing <$k>";
1321 delete $INC{$k};
1322
1323 $k =~ s/\.pm$//;
1324 $k =~ s/\//::/g;
1325
1326 if (my $cb = $k->can ("unload_module")) {
1327 $cb->();
1328 }
1329
1330 Symbol::delete_package $k;
1331 }
1332
1333 # sync database to disk
1334 cf::db_sync;
1335 IO::AIO::flush;
1336
1337 # get rid of safe::, as good as possible
1338 Symbol::delete_package "safe::$_"
1339 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1340
1341 # remove register_script_function callbacks
1342 # TODO
1343
1344 # unload cf.pm "a bit"
1345 delete $INC{"cf.pm"};
1346
1347 # don't, removes xs symbols, too,
1348 # and global variables created in xs
1349 #Symbol::delete_package __PACKAGE__;
1350
1351 # reload cf.pm
1352 warn "reloading cf.pm";
1353 require cf;
1354 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1355
1356 # load config and database again
1357 cf::cfg_load;
1358 cf::db_load;
1359
1360 # load extensions
1361 warn "load extensions";
1362 cf::load_extensions;
1363
1364 # reattach attachments to objects
1365 warn "reattach";
1366 _global_reattach;
1367 };
1368
1369 if ($@) {
1370 warn $@;
1371 warn "error while reloading, exiting.";
1372 exit 1;
1373 }
1374
1375 warn "reloaded successfully";
1376};
1377
935register "<global>", __PACKAGE__; 1378register "<global>", __PACKAGE__;
936 1379
1380register_command "perl-reload" => sub {
1381 my ($who, $arg) = @_;
1382
1383 if ($who->flag (FLAG_WIZ)) {
1384 $who->message ("start of reload.");
1385 perl_reload;
1386 $who->message ("end of reload.");
1387 }
1388};
1389
937unshift @INC, $LIBDIR; 1390unshift @INC, $LIBDIR;
938 1391
939load_extensions;
940
941$TICK_WATCHER = Event->timer ( 1392$TICK_WATCHER = Event->timer (
1393 reentrant => 0,
942 prio => 1, 1394 prio => 0,
943 at => $NEXT_TICK || 1, 1395 at => $NEXT_TICK || $TICK,
1396 data => WF_AUTOCANCEL,
944 cb => sub { 1397 cb => sub {
1398 unless ($FREEZE) {
945 cf::server_tick; # one server iteration 1399 cf::server_tick; # one server iteration
1400 $RUNTIME += $TICK;
1401 }
946 1402
947 my $NOW = Event::time;
948 $NEXT_TICK += $TICK; 1403 $NEXT_TICK += $TICK;
949 1404
950 # if we are delayed by four ticks, skip them all 1405 # if we are delayed by four ticks or more, skip them all
951 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1406 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
952 1407
953 $TICK_WATCHER->at ($NEXT_TICK); 1408 $TICK_WATCHER->at ($NEXT_TICK);
954 $TICK_WATCHER->start; 1409 $TICK_WATCHER->start;
955 }, 1410 },
956); 1411);
957 1412
958_reload_2; 1413IO::AIO::max_poll_time $TICK * 0.2;
1414
1415Event->io (fd => IO::AIO::poll_fileno,
1416 poll => 'r',
1417 prio => 5,
1418 data => WF_AUTOCANCEL,
1419 cb => \&IO::AIO::poll_cb);
1420
1421# we must not ever block the main coroutine
1422$Coro::idle = sub {
1423 #Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#
1424 warn "FATAL: Coro::idle was called, major BUG\n";
1425 (Coro::unblock_sub {
1426 Event::one_event;
1427 })->();
1428};
959 1429
9601 14301
961 1431

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines