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

Diff Legend

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