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.58 by root, Wed Aug 30 12:08:15 2006 UTC vs.
Revision 1.126 by root, Tue Jan 2 23:12:47 2007 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 Digest::MD5;
21use Fcntl;
22use IO::AIO 2.31 ();
23use YAML::Syck ();
10use Time::HiRes; 24use Time::HiRes;
11use Event; 25
12$Event::Eval = 1; # no idea why this is required, but it is 26use Event; $Event::Eval = 1; # no idea why this is required, but it is
13 27
14use strict; 28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
29$YAML::Syck::ImplicitUnicode = 1;
15 30
16_reload_1; 31$Coro::main->prio (2); # run main coroutine ("the server") with very high priority
17 32
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34
18our %COMMAND = (); 35our %COMMAND = ();
36our %COMMAND_TIME = ();
37our %EXTCMD = ();
38
19our @EVENT; 39our @EVENT;
20our %PROP_TYPE; 40our $LIBDIR = datadir . "/ext";
21our %PROP_IDX;
22our $LIBDIR = maps_directory "perl";
23 41
24our $TICK = MAX_TIME * 1e-6; 42our $TICK = MAX_TIME * 1e-6;
25our $TICK_WATCHER; 43our $TICK_WATCHER;
26our $NEXT_TICK; 44our $NEXT_TICK;
45our $NOW;
46
47our %CFG;
48
49our $UPTIME; $UPTIME ||= time;
50our $RUNTIME;
51
52our %MAP; # all maps
53our $LINK_MAP; # the special {link} map
54our $FREEZE;
55our $RANDOM_MAPS = cf::localdir . "/random";
56our %EXT_CORO;
57
58binmode STDOUT;
59binmode STDERR;
60
61# read virtual server time, if available
62unless ($RUNTIME || !-e cf::localdir . "/runtime") {
63 open my $fh, "<", cf::localdir . "/runtime"
64 or die "unable to read runtime file: $!";
65 $RUNTIME = <$fh> + 0.;
66}
67
68mkdir cf::localdir;
69mkdir cf::localdir . "/" . cf::playerdir;
70mkdir cf::localdir . "/" . cf::tmpdir;
71mkdir cf::localdir . "/" . cf::uniquedir;
72mkdir $RANDOM_MAPS;
73
74# a special map that is always available
75our $LINK_MAP;
76
77our $EMERGENCY_POSITION = $cf::CFG{emergency_position} || ["/world/world_105_115", 5, 37];
78
79#############################################################################
80
81=head2 GLOBAL VARIABLES
82
83=over 4
84
85=item $cf::UPTIME
86
87The timestamp of the server start (so not actually an uptime).
88
89=item $cf::RUNTIME
90
91The time this server has run, starts at 0 and is increased by $cf::TICK on
92every server tick.
93
94=item $cf::LIBDIR
95
96The perl library directory, where extensions and cf-specific modules can
97be found. It will be added to C<@INC> automatically.
98
99=item $cf::NOW
100
101The time of the last (current) server tick.
102
103=item $cf::TICK
104
105The interval between server ticks, in seconds.
106
107=item %cf::CFG
108
109Configuration for the server, loaded from C</etc/crossfire/config>, or
110from wherever your confdir points to.
111
112=back
113
114=cut
27 115
28BEGIN { 116BEGIN {
29 *CORE::GLOBAL::warn = sub { 117 *CORE::GLOBAL::warn = sub {
30 my $msg = join "", @_; 118 my $msg = join "", @_;
119 utf8::encode $msg;
120
31 $msg .= "\n" 121 $msg .= "\n"
32 unless $msg =~ /\n$/; 122 unless $msg =~ /\n$/;
33 123
34 print STDERR "cfperl: $msg";
35 LOG llevError, "cfperl: $msg"; 124 LOG llevError, "cfperl: $msg";
36 }; 125 };
37} 126}
38 127
39my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply! 128@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
40 129@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
41# generate property mutators 130@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
42sub prop_gen { 131@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
43 my ($prefix, $class) = @_; 132@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'; 133@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
74 134
75# we bless all objects into (empty) derived classes to force a method lookup 135# we bless all objects into (empty) derived classes to force a method lookup
76# within the Safe compartment. 136# 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)) { 137for my $pkg (qw(
138 cf::global cf::attachable
139 cf::object cf::object::player
140 cf::client cf::player
141 cf::arch cf::living
142 cf::map cf::party cf::region
143)) {
78 no strict 'refs'; 144 no strict 'refs';
79 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 145 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
80} 146}
81 147
82$Event::DIED = sub { 148$Event::DIED = sub {
84}; 150};
85 151
86my %ext_pkg; 152my %ext_pkg;
87my @exts; 153my @exts;
88my @hook; 154my @hook;
89my %command;
90my %extcmd;
91 155
92############################################################################# 156=head2 UTILITY FUNCTIONS
93# utility functions 157
158=over 4
159
160=cut
94 161
95use JSON::Syck (); # TODO# replace by JSON::PC once working 162use JSON::Syck (); # TODO# replace by JSON::PC once working
163
164=item $ref = cf::from_json $json
165
166Converts a JSON string into the corresponding perl data structure.
167
168=cut
96 169
97sub from_json($) { 170sub from_json($) {
98 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs 171 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
99 JSON::Syck::Load $_[0] 172 JSON::Syck::Load $_[0]
100} 173}
101 174
175=item $json = cf::to_json $ref
176
177Converts a perl data structure into its JSON representation.
178
179=cut
180
102sub to_json($) { 181sub to_json($) {
103 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 182 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
104 JSON::Syck::Dump $_[0] 183 JSON::Syck::Dump $_[0]
105} 184}
106 185
186=item my $guard = cf::guard { BLOCK }
187
188Run the given callback when the guard object gets destroyed (useful for
189coroutine cancellations).
190
191You can call C<< ->cancel >> on the guard object to stop the block from
192being executed.
193
194=cut
195
196sub guard(&) {
197 bless \(my $cb = $_[0]), cf::guard::;
198}
199
200sub cf::guard::cancel {
201 ${$_[0]} = sub { };
202}
203
204sub cf::guard::DESTROY {
205 ${$_[0]}->();
206}
207
208=item cf::lock_wait $string
209
210Wait until the given lock is available. See cf::lock_acquire.
211
212=item my $lock = cf::lock_acquire $string
213
214Wait until the given lock is available and then acquires it and returns
215a guard object. If the guard object gets destroyed (goes out of scope,
216for example when the coroutine gets canceled), the lock is automatically
217returned.
218
219Lock names should begin with a unique identifier (for example, find_map
220uses map_find and load_map uses map_load).
221
222=cut
223
224our %LOCK;
225
226sub lock_wait($) {
227 my ($key) = @_;
228
229 # wait for lock, if any
230 while ($LOCK{$key}) {
231 push @{ $LOCK{$key} }, $Coro::current;
232 Coro::schedule;
233 }
234}
235
236sub lock_acquire($) {
237 my ($key) = @_;
238
239 # wait, to be sure we are not locked
240 lock_wait $key;
241
242 $LOCK{$key} = [];
243
244 cf::guard {
245 # wake up all waiters, to be on the safe side
246 $_->ready for @{ delete $LOCK{$key} };
247 }
248}
249
250=item cf::sync_job { BLOCK }
251
252The design of crossfire+ requires that the main coro ($Coro::main) is
253always able to handle events or runnable, as crossfire+ is only partly
254reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.
255
256If it must be done, put the blocking parts into C<sync_job>. This will run
257the given BLOCK in another coroutine while waiting for the result. The
258server will be frozen during this time, so the block should either finish
259fast or be very important.
260
261=cut
262
263sub sync_job(&) {
264 my ($job) = @_;
265
266 if ($Coro::current == $Coro::main) {
267 # this is the main coro, too bad, we have to block
268 # till the operation succeeds, freezing the server :/
269
270 # TODO: use suspend/resume instead
271 # (but this is cancel-safe)
272 local $FREEZE = 1;
273
274 my $busy = 1;
275 my @res;
276
277 (Coro::async {
278 @res = eval { $job->() };
279 warn $@ if $@;
280 undef $busy;
281 })->prio (Coro::PRIO_MAX);
282
283 while ($busy) {
284 Coro::cede_notself;
285 Event::one_event unless Coro::nready;
286 }
287
288 wantarray ? @res : $res[0]
289 } else {
290 # we are in another coroutine, how wonderful, everything just works
291
292 $job->()
293 }
294}
295
296=item $coro = cf::coro { BLOCK }
297
298Creates and returns a new coro. This coro is automcatially being canceled
299when the extension calling this is being unloaded.
300
301=cut
302
303sub coro(&) {
304 my $cb = shift;
305
306 my $coro; $coro = async {
307 eval {
308 $cb->();
309 };
310 warn $@ if $@;
311 };
312
313 $coro->on_destroy (sub {
314 delete $EXT_CORO{$coro+0};
315 });
316 $EXT_CORO{$coro+0} = $coro;
317
318 $coro
319}
320
321sub write_runtime {
322 my $runtime = cf::localdir . "/runtime";
323
324 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
325 or return;
326
327 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock
328 (aio_write $fh, 0, (length $value), $value, 0) <= 0
329 and return;
330
331 aio_fsync $fh
332 and return;
333
334 close $fh
335 or return;
336
337 aio_rename "$runtime~", $runtime
338 and return;
339
340 1
341}
342
343=back
344
345=cut
346
107############################################################################# 347#############################################################################
108# "new" plug-in system
109 348
110=head3 EVENTS AND OBJECT ATTACHMENTS 349package cf::path;
350
351sub new {
352 my ($class, $path, $base) = @_;
353
354 $path = $path->as_string if ref $path;
355
356 my $self = bless { }, $class;
357
358 # {... are special paths that are not touched
359 # ?xxx/... are special absolute paths
360 # ?random/... random maps
361 # /! non-realised random map exit
362 # /... normal maps
363 # ~/... per-player maps without a specific player (DO NOT USE)
364 # ~user/... per-player map of a specific user
365
366 if ($path =~ /^{/) {
367 # fine as it is
368 } elsif ($path =~ s{^\?random/}{}) {
369 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
370 $self->{random} = cf::from_json $data;
371 } else {
372 if ($path =~ s{^~([^/]+)?}{}) {
373 $self->{user_rel} = 1;
374
375 if (defined $1) {
376 $self->{user} = $1;
377 } elsif ($base =~ m{^~([^/]+)/}) {
378 $self->{user} = $1;
379 } else {
380 warn "cannot resolve user-relative path without user <$path,$base>\n";
381 }
382 } elsif ($path =~ /^\//) {
383 # already absolute
384 } else {
385 $base =~ s{[^/]+/?$}{};
386 return $class->new ("$base/$path");
387 }
388
389 for ($path) {
390 redo if s{/\.?/}{/};
391 redo if s{/[^/]+/\.\./}{/};
392 }
393 }
394
395 $self->{path} = $path;
396
397 $self
398}
399
400# the name / primary key / in-game path
401sub as_string {
402 my ($self) = @_;
403
404 $self->{user_rel} ? "~$self->{user}$self->{path}"
405 : $self->{random} ? "?random/$self->{path}"
406 : $self->{path}
407}
408
409# the displayed name, this is a one way mapping
410sub visible_name {
411 my ($self) = @_;
412
413# if (my $rmp = $self->{random}) {
414# # todo: be more intelligent about this
415# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
416# } else {
417 $self->as_string
418# }
419}
420
421# escape the /'s in the path
422sub _escaped_path {
423 # ∕ is U+2215
424 (my $path = $_[0]{path}) =~ s/\//∕/g;
425 $path
426}
427
428# the original (read-only) location
429sub load_path {
430 my ($self) = @_;
431
432 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
433}
434
435# the temporary/swap location
436sub save_path {
437 my ($self) = @_;
438
439 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
440 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
441 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
442}
443
444# the unique path, might be eq to save_path
445sub uniq_path {
446 my ($self) = @_;
447
448 $self->{user_rel} || $self->{random}
449 ? undef
450 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
451}
452
453# return random map parameters, or undef
454sub random_map_params {
455 my ($self) = @_;
456
457 $self->{random}
458}
459
460# this is somewhat ugly, but style maps do need special treatment
461sub is_style_map {
462 $_[0]{path} =~ m{^/styles/}
463}
464
465package cf;
466
467#############################################################################
468
469=head2 ATTACHABLE OBJECTS
470
471Many objects in crossfire are so-called attachable objects. That means you can
472attach callbacks/event handlers (a collection of which is called an "attachment")
473to it. All such attachable objects support the following methods.
474
475In the following description, CLASS can be any of C<global>, C<object>
476C<player>, C<client> or C<map> (i.e. the attachable objects in
477crossfire+).
111 478
112=over 4 479=over 4
113 480
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...) 481=item $attachable->attach ($attachment, key => $value...)
127 482
128=item $map->detach ($attachment) 483=item $attachable->detach ($attachment)
129 484
130Attach/detach a pre-registered attachment to a map. 485Attach/detach a pre-registered attachment to a specific object and give it
486the specified key/value pairs as arguments.
131 487
132=item $bool = $object->attached ($name) 488Example, attach a minesweeper attachment to the given object, making it a
48910x10 minesweeper game:
133 490
134=item $bool = $player->attached ($name) 491 $obj->attach (minesweeper => width => 10, height => 10);
135 492
136=item $bool = $map->attached ($name) 493=item $bool = $attachable->attached ($name)
137 494
138Checks wether the named attachment is currently attached to the object. 495Checks wether the named attachment is currently attached to the object.
139 496
140=item cf::attach_global ... 497=item cf::CLASS->attach ...
141 498
142Attach handlers for global events. 499=item cf::CLASS->detach ...
143 500
144This and all following C<attach_*>-functions expect any number of the 501Define an anonymous attachment and attach it to all objects of the given
145following handler/hook descriptions: 502CLASS. See the next function for an explanation of its arguments.
503
504You can attach to global events by using the C<cf::global> class.
505
506Example, log all player logins:
507
508 cf::player->attach (
509 on_login => sub {
510 my ($pl) = @_;
511 ...
512 },
513 );
514
515Example, attach to the jeweler skill:
516
517 cf::object->attach (
518 type => cf::SKILL,
519 subtype => cf::SK_JEWELER,
520 on_use_skill => sub {
521 my ($sk, $ob, $part, $dir, $msg) = @_;
522 ...
523 },
524 );
525
526=item cf::CLASS::attachment $name, ...
527
528Register an attachment by C<$name> through which attachable objects of the
529given CLASS can refer to this attachment.
530
531Some classes such as crossfire maps and objects can specify attachments
532that are attached at load/instantiate time, thus the need for a name.
533
534These calls expect any number of the following handler/hook descriptions:
146 535
147=over 4 536=over 4
148 537
149=item prio => $number 538=item prio => $number
150 539
152by another C<prio> setting). Lower priority handlers get executed 541by another C<prio> setting). Lower priority handlers get executed
153earlier. The default priority is C<0>, and many built-in handlers are 542earlier. The default priority is C<0>, and many built-in handlers are
154registered at priority C<-1000>, so lower priorities should not be used 543registered at priority C<-1000>, so lower priorities should not be used
155unless you know what you are doing. 544unless you know what you are doing.
156 545
546=item type => $type
547
548(Only for C<< cf::object->attach >> calls), limits the attachment to the
549given type of objects only (the additional parameter C<subtype> can be
550used to further limit to the given subtype).
551
157=item on_I<event> => \&cb 552=item on_I<event> => \&cb
158 553
159Call the given code reference whenever the named event happens (event is 554Call 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 555something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
161handlers are recognised generally depends on the type of object these 556handlers are recognised generally depends on the type of object these
170package and register them. Only handlers for eevents supported by the 565package and register them. Only handlers for eevents supported by the
171object/class are recognised. 566object/class are recognised.
172 567
173=back 568=back
174 569
175=item cf::attach_to_type $object_type, $subtype, ... 570Example, define an attachment called "sockpuppet" that calls the given
571event handler when a monster attacks:
176 572
177Attach handlers for a specific object type (e.g. TRANSPORT) and 573 cf::object::attachment sockpuppet =>
178subtype. If C<$subtype> is zero or undef, matches all objects of the given 574 on_skill_attack => sub {
179type. 575 my ($self, $victim) = @_;
180 576 ...
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 } 577 }
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 578 }
402}
403 579
404=item $bool = cf::invoke EVENT_GLOBAL_XXX, ... 580=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 581
430Just because you have a perl object does not mean that the corresponding 582Just 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 583C-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 584valid 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 585can be used to test for existence of the C object part without causing an
434exception. 586exception.
435 587
588=cut
589
590# the following variables are defined in .xs and must not be re-created
591our @CB_GLOBAL = (); # registry for all global events
592our @CB_ATTACHABLE = (); # registry for all attachables
593our @CB_OBJECT = (); # all objects (should not be used except in emergency)
594our @CB_PLAYER = ();
595our @CB_CLIENT = ();
596our @CB_TYPE = (); # registry for type (cf-object class) based events
597our @CB_MAP = ();
598
599my %attachment;
600
601sub _attach_cb($$$$) {
602 my ($registry, $event, $prio, $cb) = @_;
603
604 use sort 'stable';
605
606 $cb = [$prio, $cb];
607
608 @{$registry->[$event]} = sort
609 { $a->[0] cmp $b->[0] }
610 @{$registry->[$event] || []}, $cb;
611}
612
613# hack
614my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
615
616# attach handles attaching event callbacks
617# the only thing the caller has to do is pass the correct
618# registry (== where the callback attaches to).
619sub _attach {
620 my ($registry, $klass, @arg) = @_;
621
622 my $object_type;
623 my $prio = 0;
624 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
625
626 #TODO: get rid of this hack
627 if ($attachable_klass{$klass}) {
628 %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
629 }
630
631 while (@arg) {
632 my $type = shift @arg;
633
634 if ($type eq "prio") {
635 $prio = shift @arg;
636
637 } elsif ($type eq "type") {
638 $object_type = shift @arg;
639 $registry = $CB_TYPE[$object_type] ||= [];
640
641 } elsif ($type eq "subtype") {
642 defined $object_type or Carp::croak "subtype specified without type";
643 my $object_subtype = shift @arg;
644 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= [];
645
646 } elsif ($type eq "package") {
647 my $pkg = shift @arg;
648
649 while (my ($name, $id) = each %cb_id) {
650 if (my $cb = $pkg->can ($name)) {
651 _attach_cb $registry, $id, $prio, $cb;
652 }
653 }
654
655 } elsif (exists $cb_id{$type}) {
656 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
657
658 } elsif (ref $type) {
659 warn "attaching objects not supported, ignoring.\n";
660
661 } else {
662 shift @arg;
663 warn "attach argument '$type' not supported, ignoring.\n";
664 }
665 }
666}
667
668sub _object_attach {
669 my ($obj, $name, %arg) = @_;
670
671 return if exists $obj->{_attachment}{$name};
672
673 if (my $attach = $attachment{$name}) {
674 my $registry = $obj->registry;
675
676 for (@$attach) {
677 my ($klass, @attach) = @$_;
678 _attach $registry, $klass, @attach;
679 }
680
681 $obj->{$name} = \%arg;
682 } else {
683 warn "object uses attachment '$name' that is not available, postponing.\n";
684 }
685
686 $obj->{_attachment}{$name} = undef;
687}
688
689sub cf::attachable::attach {
690 if (ref $_[0]) {
691 _object_attach @_;
692 } else {
693 _attach shift->_attach_registry, @_;
694 }
695};
696
697# all those should be optimised
698sub cf::attachable::detach {
699 my ($obj, $name) = @_;
700
701 if (ref $obj) {
702 delete $obj->{_attachment}{$name};
703 reattach ($obj);
704 } else {
705 Carp::croak "cannot, currently, detach class attachments";
706 }
707};
708
709sub cf::attachable::attached {
710 my ($obj, $name) = @_;
711
712 exists $obj->{_attachment}{$name}
713}
714
715for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
716 eval "#line " . __LINE__ . " 'cf.pm'
717 sub cf::\L$klass\E::_attach_registry {
718 (\\\@CB_$klass, KLASS_$klass)
719 }
720
721 sub cf::\L$klass\E::attachment {
722 my \$name = shift;
723
724 \$attachment{\$name} = [[KLASS_$klass, \@_]];
725 }
726 ";
727 die if $@;
728}
729
730our $override;
731our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
732
733sub override {
734 $override = 1;
735 @invoke_results = ();
736}
737
738sub do_invoke {
739 my $event = shift;
740 my $callbacks = shift;
741
742 @invoke_results = ();
743
744 local $override;
745
746 for (@$callbacks) {
747 eval { &{$_->[1]} };
748
749 if ($@) {
750 warn "$@";
751 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
752 override;
753 }
754
755 return 1 if $override;
756 }
757
758 0
759}
760
761=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)
762
763=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
764
765Generate an object-specific event with the given arguments.
766
767This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
768removed in future versions), and there is no public API to access override
769results (if you must, access C<@cf::invoke_results> directly).
770
436=back 771=back
437 772
438=cut 773=cut
439
440*cf::object::valid =
441*cf::player::valid =
442*cf::map::valid = \&cf::_valid;
443 774
444############################################################################# 775#############################################################################
445# object support 776# object support
446 777
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 { 778sub reattach {
779 # basically do the same as instantiate, without calling instantiate
461 my ($obj) = @_; 780 my ($obj) = @_;
781
462 my $registry = $obj->registry; 782 my $registry = $obj->registry;
463 783
464 @$registry = (); 784 @$registry = ();
465 785
466 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} }; 786 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
467 787
468 for my $name (keys %{ $obj->{_attachment} || {} }) { 788 for my $name (keys %{ $obj->{_attachment} || {} }) {
469 if (my $attach = $attachment{$name}) { 789 if (my $attach = $attachment{$name}) {
470 for (@$attach) { 790 for (@$attach) {
471 my ($klass, @attach) = @$_; 791 my ($klass, @attach) = @$_;
472 _attach @$registry, $klass, @attach; 792 _attach $registry, $klass, @attach;
473 } 793 }
474 } else { 794 } else {
475 warn "object uses attachment '$name' that is not available, postponing.\n"; 795 warn "object uses attachment '$name' that is not available, postponing.\n";
476 } 796 }
477 } 797 }
478} 798}
479 799
480sub object_freezer_save { 800cf::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, 801 prio => -1000000,
802 on_instantiate => sub {
803 my ($obj, $data) = @_;
804
805 $data = from_json $data;
806
807 for (@$data) {
808 my ($name, $args) = @$_;
809
810 $obj->attach ($name, %{$args || {} });
811 }
812 },
813 on_reattach => \&reattach,
508 on_clone => sub { 814 on_clone => sub {
509 my ($src, $dst) = @_; 815 my ($src, $dst) = @_;
510 816
511 @{$dst->registry} = @{$src->registry}; 817 @{$dst->registry} = @{$src->registry};
512 818
513 %$dst = %$src; 819 %$dst = %$src;
514 820
515 %{$dst->{_attachment}} = %{$src->{_attachment}} 821 %{$dst->{_attachment}} = %{$src->{_attachment}}
516 if exists $src->{_attachment}; 822 if exists $src->{_attachment};
517 }, 823 },
518; 824);
825
826sub object_freezer_save {
827 my ($filename, $rdata, $objs) = @_;
828
829 sync_job {
830 if (length $$rdata) {
831 warn sprintf "saving %s (%d,%d)\n",
832 $filename, length $$rdata, scalar @$objs;
833
834 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
835 chmod SAVE_MODE, $fh;
836 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
837 aio_fsync $fh;
838 close $fh;
839
840 if (@$objs) {
841 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
842 chmod SAVE_MODE, $fh;
843 my $data = Storable::nfreeze { version => 1, objs => $objs };
844 aio_write $fh, 0, (length $data), $data, 0;
845 aio_fsync $fh;
846 close $fh;
847 aio_rename "$filename.pst~", "$filename.pst";
848 }
849 } else {
850 aio_unlink "$filename.pst";
851 }
852
853 aio_rename "$filename~", $filename;
854 } else {
855 warn "FATAL: $filename~: $!\n";
856 }
857 } else {
858 aio_unlink $filename;
859 aio_unlink "$filename.pst";
860 }
861 }
862}
863
864sub object_freezer_as_string {
865 my ($rdata, $objs) = @_;
866
867 use Data::Dumper;
868
869 $$rdata . Dumper $objs
870}
871
872sub object_thawer_load {
873 my ($filename) = @_;
874
875 my ($data, $av);
876
877 (aio_load $filename, $data) >= 0
878 or return;
879
880 unless (aio_stat "$filename.pst") {
881 (aio_load "$filename.pst", $av) >= 0
882 or return;
883 $av = eval { (Storable::thaw $av)->{objs} };
884 }
885
886 warn sprintf "loading %s (%d)\n",
887 $filename, length $data, scalar @{$av || []};#d#
888 return ($data, $av);
889}
519 890
520############################################################################# 891#############################################################################
521# old plug-in events 892# command handling &c
522 893
523sub inject_event { 894=item cf::register_command $name => \&callback($ob,$args);
524 my $extension = shift;
525 my $event_code = shift;
526 895
527 my $cb = $hook[$event_code]{$extension} 896Register a callback for execution when the client sends the user command
528 or return; 897$name.
529 898
530 &$cb 899=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 900
552sub register_command { 901sub register_command {
553 my ($name, $time, $cb) = @_; 902 my ($name, $cb) = @_;
554 903
555 my $caller = caller; 904 my $caller = caller;
556 #warn "registering command '$name/$time' to '$caller'"; 905 #warn "registering command '$name/$time' to '$caller'";
557 906
558 push @{ $command{$name} }, [$time, $cb, $caller]; 907 push @{ $COMMAND{$name} }, [$caller, $cb];
559 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
560} 908}
909
910=item cf::register_extcmd $name => \&callback($pl,$packet);
911
912Register a callbackf ro execution when the client sends an extcmd packet.
913
914If the callback returns something, it is sent back as if reply was being
915called.
916
917=cut
561 918
562sub register_extcmd { 919sub register_extcmd {
563 my ($name, $cb) = @_; 920 my ($name, $cb) = @_;
564 921
565 my $caller = caller; 922 my $caller = caller;
566 #warn "registering extcmd '$name' to '$caller'"; 923 #warn "registering extcmd '$name' to '$caller'";
567 924
568 $extcmd{$name} = [$cb, $caller]; 925 $EXTCMD{$name} = [$cb, $caller];
569} 926}
927
928cf::player->attach (
929 on_command => sub {
930 my ($pl, $name, $params) = @_;
931
932 my $cb = $COMMAND{$name}
933 or return;
934
935 for my $cmd (@$cb) {
936 $cmd->[1]->($pl->ob, $params);
937 }
938
939 cf::override;
940 },
941 on_extcmd => sub {
942 my ($pl, $buf) = @_;
943
944 my $msg = eval { from_json $buf };
945
946 if (ref $msg) {
947 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
948 if (my %reply = $cb->[0]->($pl, $msg)) {
949 $pl->ext_reply ($msg->{msgid}, %reply);
950 }
951 }
952 } else {
953 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
954 }
955
956 cf::override;
957 },
958);
570 959
571sub register { 960sub register {
572 my ($base, $pkg) = @_; 961 my ($base, $pkg) = @_;
573 962
574 #TODO 963 #TODO
593 . "#line 1 \"$path\"\n{\n" 982 . "#line 1 \"$path\"\n{\n"
594 . (do { local $/; <$fh> }) 983 . (do { local $/; <$fh> })
595 . "\n};\n1"; 984 . "\n};\n1";
596 985
597 eval $source 986 eval $source
598 or die "$path: $@"; 987 or die $@ ? "$path: $@\n"
988 : "extension disabled.\n";
599 989
600 push @exts, $pkg; 990 push @exts, $pkg;
601 $ext_pkg{$base} = $pkg; 991 $ext_pkg{$base} = $pkg;
602 992
603# no strict 'refs'; 993# no strict 'refs';
616# for my $idx (0 .. $#PLUGIN_EVENT) { 1006# for my $idx (0 .. $#PLUGIN_EVENT) {
617# delete $hook[$idx]{$pkg}; 1007# delete $hook[$idx]{$pkg};
618# } 1008# }
619 1009
620 # remove commands 1010 # remove commands
621 for my $name (keys %command) { 1011 for my $name (keys %COMMAND) {
622 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 1012 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
623 1013
624 if (@cb) { 1014 if (@cb) {
625 $command{$name} = \@cb; 1015 $COMMAND{$name} = \@cb;
626 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
627 } else { 1016 } else {
628 delete $command{$name};
629 delete $COMMAND{"$name\000"}; 1017 delete $COMMAND{$name};
630 } 1018 }
631 } 1019 }
632 1020
633 # remove extcmds 1021 # remove extcmds
634 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 1022 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
635 delete $extcmd{$name}; 1023 delete $EXTCMD{$name};
636 } 1024 }
637 1025
638 if (my $cb = $pkg->can ("unload")) { 1026 if (my $cb = $pkg->can ("unload")) {
639 eval { 1027 eval {
640 $cb->($pkg); 1028 $cb->($pkg);
644 1032
645 Symbol::delete_package $pkg; 1033 Symbol::delete_package $pkg;
646} 1034}
647 1035
648sub load_extensions { 1036sub load_extensions {
649 my $LIBDIR = maps_directory "perl";
650
651 for my $ext (<$LIBDIR/*.ext>) { 1037 for my $ext (<$LIBDIR/*.ext>) {
652 next unless -r $ext; 1038 next unless -r $ext;
653 eval { 1039 eval {
654 load_extension $ext; 1040 load_extension $ext;
655 1 1041 1
656 } or warn "$ext not loaded: $@"; 1042 } or warn "$ext not loaded: $@";
657 } 1043 }
658} 1044}
659 1045
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############################################################################# 1046#############################################################################
758# load/save/clean perl data associated with a map 1047# load/save/clean perl data associated with a map
759 1048
760*cf::mapsupport::on_clean = sub { 1049*cf::mapsupport::on_clean = sub {
761 my ($map) = @_; 1050 my ($map) = @_;
764 defined $path or return; 1053 defined $path or return;
765 1054
766 unlink "$path.pst"; 1055 unlink "$path.pst";
767}; 1056};
768 1057
769attach_to_maps prio => -10000, package => cf::mapsupport::; 1058cf::map->attach (prio => -10000, package => cf::mapsupport::);
770 1059
771############################################################################# 1060#############################################################################
772# load/save perl data associated with player->ob objects 1061# load/save perl data associated with player->ob objects
773 1062
774sub all_objects(@) { 1063sub all_objects(@) {
775 @_, map all_objects ($_->inv), @_ 1064 @_, map all_objects ($_->inv), @_
776} 1065}
777 1066
778attach_to_players 1067# TODO: compatibility cruft, remove when no longer needed
1068cf::player->attach (
779 on_load => sub { 1069 on_load => sub {
780 my ($pl, $path) = @_; 1070 my ($pl, $path) = @_;
781 1071
782 for my $o (all_objects $pl->ob) { 1072 for my $o (all_objects $pl->ob) {
783 if (my $value = $o->get_ob_key_value ("_perl_data")) { 1073 if (my $value = $o->get_ob_key_value ("_perl_data")) {
785 1075
786 %$o = %{ Storable::thaw pack "H*", $value }; 1076 %$o = %{ Storable::thaw pack "H*", $value };
787 } 1077 }
788 } 1078 }
789 }, 1079 },
790; 1080);
791 1081
792############################################################################# 1082#############################################################################
793# core extensions - in perl 1083
1084=head2 CORE EXTENSIONS
1085
1086Functions and methods that extend core crossfire objects.
1087
1088=head3 cf::player
1089
1090=over 4
794 1091
795=item cf::player::exists $login 1092=item cf::player::exists $login
796 1093
797Returns true when the given account exists. 1094Returns true when the given account exists.
798 1095
801sub cf::player::exists($) { 1098sub cf::player::exists($) {
802 cf::player::find $_[0] 1099 cf::player::find $_[0]
803 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 1100 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
804} 1101}
805 1102
1103=item $player->ext_reply ($msgid, $msgtype, %msg)
1104
1105Sends an ext reply to the player.
1106
1107=cut
1108
1109sub cf::player::ext_reply($$$%) {
1110 my ($self, $id, %msg) = @_;
1111
1112 $msg{msgid} = $id;
1113
1114 $self->send ("ext " . to_json \%msg);
1115}
1116
1117=back
1118
1119
1120=head3 cf::map
1121
1122=over 4
1123
1124=cut
1125
1126package cf::map;
1127
1128use Fcntl;
1129use Coro::AIO;
1130
1131our $MAX_RESET = 7200;
1132our $DEFAULT_RESET = 3600;
1133
1134sub generate_random_map {
1135 my ($path, $rmp) = @_;
1136
1137 # mit "rum" bekleckern, nicht
1138 cf::map::_create_random_map
1139 $path,
1140 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1141 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1142 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1143 $rmp->{exit_on_final_map},
1144 $rmp->{xsize}, $rmp->{ysize},
1145 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1146 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1147 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1148 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1149 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1150 (cf::region::find $rmp->{region})
1151}
1152
1153# and all this just because we cannot iterate over
1154# all maps in C++...
1155sub change_all_map_light {
1156 my ($change) = @_;
1157
1158 $_->change_map_light ($change)
1159 for grep $_->outdoor, values %cf::MAP;
1160}
1161
1162sub try_load_header($) {
1163 my ($path) = @_;
1164
1165 utf8::encode $path;
1166 aio_open $path, O_RDONLY, 0
1167 or return;
1168
1169 my $map = cf::map::new
1170 or return;
1171
1172 $map->load_header ($path)
1173 or return;
1174
1175 $map->{load_path} = $path;
1176
1177 $map
1178}
1179
1180sub find_map;
1181sub find_map {
1182 my ($path, $origin) = @_;
1183
1184 #warn "find_map<$path,$origin>\n";#d#
1185
1186 $path = new cf::path $path, $origin && $origin->path;
1187 my $key = $path->as_string;
1188
1189 cf::lock_wait "map_find:$key";
1190
1191 $cf::MAP{$key} || do {
1192 my $guard = cf::lock_acquire "map_find:$key";
1193
1194 # do it the slow way
1195 my $map = try_load_header $path->save_path;
1196
1197 if ($map) {
1198 # safety
1199 $map->{instantiate_time} = $cf::RUNTIME
1200 if $map->{instantiate_time} > $cf::RUNTIME;
1201 } else {
1202 if (my $rmp = $path->random_map_params) {
1203 $map = generate_random_map $key, $rmp;
1204 } else {
1205 $map = try_load_header $path->load_path;
1206 }
1207
1208 $map or return;
1209
1210 $map->{load_original} = 1;
1211 $map->{instantiate_time} = $cf::RUNTIME;
1212 $map->instantiate;
1213
1214 # per-player maps become, after loading, normal maps
1215 $map->per_player (0) if $path->{user_rel};
1216 }
1217
1218 $map->path ($key);
1219 $map->{path} = $path;
1220 $map->{last_save} = $cf::RUNTIME;
1221 $map->last_access ($cf::RUNTIME);
1222
1223 if ($map->should_reset) {
1224 $map->reset;
1225 undef $guard;
1226 $map = find_map $path
1227 or return;
1228 }
1229
1230 $cf::MAP{$key} = $map
1231 }
1232}
1233
1234sub load {
1235 my ($self) = @_;
1236
1237 my $path = $self->{path};
1238 my $guard = cf::lock_acquire "map_load:" . $path->as_string;
1239
1240 return if $self->in_memory != cf::MAP_SWAPPED;
1241
1242 $self->in_memory (cf::MAP_LOADING);
1243
1244 $self->alloc;
1245 $self->load_objects ($self->{load_path}, 1)
1246 or return;
1247
1248 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1249 if delete $self->{load_original};
1250
1251 if (my $uniq = $path->uniq_path) {
1252 utf8::encode $uniq;
1253 if (aio_open $uniq, O_RDONLY, 0) {
1254 $self->clear_unique_items;
1255 $self->load_objects ($uniq, 0);
1256 }
1257 }
1258
1259 # now do the right thing for maps
1260 $self->link_multipart_objects;
1261
1262 if ($self->{path}->is_style_map) {
1263 $self->{deny_save} = 1;
1264 $self->{deny_reset} = 1;
1265 } else {
1266 $self->fix_auto_apply;
1267 $self->decay_objects;
1268 $self->update_buttons;
1269 $self->set_darkness_map;
1270 $self->difficulty ($self->estimate_difficulty)
1271 unless $self->difficulty;
1272 $self->activate;
1273 }
1274
1275 $self->in_memory (cf::MAP_IN_MEMORY);
1276}
1277
1278sub load_map_sync {
1279 my ($path, $origin) = @_;
1280
1281 #warn "load_map_sync<$path, $origin>\n";#d#
1282
1283 cf::sync_job {
1284 my $map = cf::map::find_map $path, $origin
1285 or return;
1286 $map->load;
1287 $map
1288 }
1289}
1290
1291sub save {
1292 my ($self) = @_;
1293
1294 $self->{last_save} = $cf::RUNTIME;
1295
1296 return unless $self->dirty;
1297
1298 my $save = $self->{path}->save_path; utf8::encode $save;
1299 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
1300
1301 $self->{load_path} = $save;
1302
1303 return if $self->{deny_save};
1304
1305 if ($uniq) {
1306 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1307 $self->save_objects ($uniq, cf::IO_UNIQUES);
1308 } else {
1309 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1310 }
1311}
1312
1313sub swap_out {
1314 my ($self) = @_;
1315
1316 return if $self->players;
1317 return if $self->in_memory != cf::MAP_IN_MEMORY;
1318 return if $self->{deny_save};
1319
1320 $self->save;
1321 $self->clear;
1322 $self->in_memory (cf::MAP_SWAPPED);
1323}
1324
1325sub reset_at {
1326 my ($self) = @_;
1327
1328 # TODO: safety, remove and allow resettable per-player maps
1329 return 1e99 if $self->{path}{user_rel};
1330 return 1e99 if $self->{deny_reset};
1331
1332 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1333 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1334
1335 $time + $to
1336}
1337
1338sub should_reset {
1339 my ($self) = @_;
1340
1341 $self->reset_at <= $cf::RUNTIME
1342}
1343
1344sub unlink_save {
1345 my ($self) = @_;
1346
1347 utf8::encode (my $save = $self->{path}->save_path);
1348 aioreq_pri 3; IO::AIO::aio_unlink $save;
1349 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1350}
1351
1352sub rename {
1353 my ($self, $new_path) = @_;
1354
1355 $self->unlink_save;
1356
1357 delete $cf::MAP{$self->path};
1358 $self->{path} = new cf::path $new_path;
1359 $self->path ($self->{path}->as_string);
1360 $cf::MAP{$self->path} = $self;
1361
1362 $self->save;
1363}
1364
1365sub reset {
1366 my ($self) = @_;
1367
1368 return if $self->players;
1369 return if $self->{path}{user_rel};#d#
1370
1371 warn "resetting map ", $self->path;#d#
1372
1373 delete $cf::MAP{$self->path};
1374
1375 $_->clear_links_to ($self) for values %cf::MAP;
1376
1377 $self->unlink_save;
1378 $self->destroy;
1379}
1380
1381my $nuke_counter = "aaaa";
1382
1383sub nuke {
1384 my ($self) = @_;
1385
1386 $self->{deny_save} = 1;
1387 $self->reset_timeout (1);
1388 $self->rename ("{nuke}/" . ($nuke_counter++));
1389 $self->reset; # polite request, might not happen
1390}
1391
1392sub customise_for {
1393 my ($map, $ob) = @_;
1394
1395 if ($map->per_player) {
1396 return cf::map::find_map "~" . $ob->name . "/" . $map->{path}{path};
1397 }
1398
1399 $map
1400}
1401
1402sub emergency_save {
1403 local $cf::FREEZE = 1;
1404
1405 warn "enter emergency map save\n";
1406
1407 cf::sync_job {
1408 warn "begin emergency map save\n";
1409 $_->save for values %cf::MAP;
1410 };
1411
1412 warn "end emergency map save\n";
1413}
1414
1415package cf;
1416
1417=back
1418
1419
1420=head3 cf::object::player
1421
1422=over 4
1423
806=item $player->reply ($npc, $msg[, $flags]) 1424=item $player_object->reply ($npc, $msg[, $flags])
807 1425
808Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 1426Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
809can be C<undef>. Does the right thing when the player is currently in a 1427can be C<undef>. Does the right thing when the player is currently in a
810dialogue with the given NPC character. 1428dialogue with the given NPC character.
811 1429
812=cut 1430=cut
813 1431
814# rough implementation of a future "reply" method that works 1432# rough implementation of a future "reply" method that works
815# with dialog boxes. 1433# with dialog boxes.
1434#TODO: the first argument must go, split into a $npc->reply_to ( method
816sub cf::object::player::reply($$$;$) { 1435sub cf::object::player::reply($$$;$) {
817 my ($self, $npc, $msg, $flags) = @_; 1436 my ($self, $npc, $msg, $flags) = @_;
818 1437
819 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 1438 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
820 1439
824 $msg = $npc->name . " says: $msg" if $npc; 1443 $msg = $npc->name . " says: $msg" if $npc;
825 $self->message ($msg, $flags); 1444 $self->message ($msg, $flags);
826 } 1445 }
827} 1446}
828 1447
829=item $player->ext_reply ($msgid, $msgtype, %msg) 1448=item $player_object->may ("access")
830 1449
831Sends an ext reply to the player. 1450Returns wether the given player is authorized to access resource "access"
1451(e.g. "command_wizcast").
832 1452
833=cut 1453=cut
834 1454
835sub cf::player::ext_reply($$$%) { 1455sub cf::object::player::may {
1456 my ($self, $access) = @_;
1457
1458 $self->flag (cf::FLAG_WIZ) ||
1459 (ref $cf::CFG{"may_$access"}
1460 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
1461 : $cf::CFG{"may_$access"})
1462}
1463
1464=item $player_object->enter_link
1465
1466Freezes the player and moves him/her to a special map (C<{link}>).
1467
1468The player should be reaosnably safe there for short amounts of time. You
1469I<MUST> call C<leave_link> as soon as possible, though.
1470
1471=item $player_object->leave_link ($map, $x, $y)
1472
1473Moves the player out of the specila link map onto the given map. If the
1474map is not valid (or omitted), the player will be moved back to the
1475location he/she was before the call to C<enter_link>, or, if that fails,
1476to the emergency map position.
1477
1478Might block.
1479
1480=cut
1481
1482sub cf::object::player::enter_link {
1483 my ($self) = @_;
1484
1485 $self->deactivate_recursive;
1486
1487 return if $self->map == $LINK_MAP;
1488
1489 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1490 if $self->map;
1491
1492 $self->enter_map ($LINK_MAP, 20, 20);
1493}
1494
1495sub cf::object::player::leave_link {
1496 my ($self, $map, $x, $y) = @_;
1497
1498 my $link_pos = delete $self->{_link_pos};
1499
1500 unless ($map) {
1501 # restore original map position
1502 ($map, $x, $y) = @{ $link_pos || [] };
1503 $map = cf::map::find_map $map;
1504
1505 unless ($map) {
1506 ($map, $x, $y) = @$EMERGENCY_POSITION;
1507 $map = cf::map::find_map $map
1508 or die "FATAL: cannot load emergency map\n";
1509 }
1510 }
1511
1512 ($x, $y) = (-1, -1)
1513 unless (defined $x) && (defined $y);
1514
1515 # use -1 or undef as default coordinates, not 0, 0
1516 ($x, $y) = ($map->enter_x, $map->enter_y)
1517 if $x <=0 && $y <= 0;
1518
1519 $map->load;
1520
1521 $self->activate_recursive;
1522 $self->enter_map ($map, $x, $y);
1523}
1524
1525cf::player->attach (
1526 on_logout => sub {
1527 my ($pl) = @_;
1528
1529 # abort map switching before logout
1530 if ($pl->ob->{_link_pos}) {
1531 cf::sync_job {
1532 $pl->ob->leave_link
1533 };
1534 }
1535 },
1536 on_login => sub {
1537 my ($pl) = @_;
1538
1539 # try to abort aborted map switching on player login :)
1540 # should happen only on crashes
1541 if ($pl->ob->{_link_pos}) {
1542 $pl->ob->enter_link;
1543 Coro::async {
1544 # we need this sleep as the login has a concurrent enter_exit running
1545 # and this sleep increases chances of the player not ending up in scorn
1546 Coro::Timer::sleep 1;
1547 $pl->ob->leave_link;
1548 };
1549 }
1550 },
1551);
1552
1553=item $player_object->goto_map ($path, $x, $y)
1554
1555=cut
1556
1557sub cf::object::player::goto_map {
1558 my ($self, $path, $x, $y) = @_;
1559
1560 $self->enter_link;
1561
1562 (Coro::async {
1563 $path = new cf::path $path;
1564
1565 my $map = cf::map::find_map $path->as_string;
1566 $map = $map->customise_for ($self) if $map;
1567
1568# warn "entering ", $map->path, " at ($x, $y)\n"
1569# if $map;
1570
1571 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1572
1573 $self->leave_link ($map, $x, $y);
1574 })->prio (1);
1575}
1576
1577=item $player_object->enter_exit ($exit_object)
1578
1579=cut
1580
1581sub parse_random_map_params {
1582 my ($spec) = @_;
1583
1584 my $rmp = { # defaults
1585 xsize => 10,
1586 ysize => 10,
1587 };
1588
1589 for (split /\n/, $spec) {
1590 my ($k, $v) = split /\s+/, $_, 2;
1591
1592 $rmp->{lc $k} = $v if (length $k) && (length $v);
1593 }
1594
1595 $rmp
1596}
1597
1598sub prepare_random_map {
1599 my ($exit) = @_;
1600
1601 # all this does is basically replace the /! path by
1602 # a new random map path (?random/...) with a seed
1603 # that depends on the exit object
1604
1605 my $rmp = parse_random_map_params $exit->msg;
1606
1607 if ($exit->map) {
1608 $rmp->{region} = $exit->map->region_name;
1609 $rmp->{origin_map} = $exit->map->path;
1610 $rmp->{origin_x} = $exit->x;
1611 $rmp->{origin_y} = $exit->y;
1612 }
1613
1614 $rmp->{random_seed} ||= $exit->random_seed;
1615
1616 my $data = cf::to_json $rmp;
1617 my $md5 = Digest::MD5::md5_hex $data;
1618
1619 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) {
1620 aio_write $fh, 0, (length $data), $data, 0;
1621
1622 $exit->slaying ("?random/$md5");
1623 $exit->msg (undef);
1624 }
1625}
1626
1627sub cf::object::player::enter_exit {
836 my ($self, $id, %msg) = @_; 1628 my ($self, $exit) = @_;
837 1629
838 $msg{msgid} = $id; 1630 return unless $self->type == cf::PLAYER;
839 1631
840 $self->send ("ext " . to_json \%msg); 1632 $self->enter_link;
841}
842 1633
843############################################################################# 1634 (Coro::async {
844# map scripting support 1635 unless (eval {
1636
1637 prepare_random_map $exit
1638 if $exit->slaying eq "/!";
1639
1640 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1641 $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp);
1642
1643 1;
1644 }) {
1645 $self->message ("Something went wrong deep within the crossfire server. "
1646 . "I'll try to bring you back to the map you were before. "
1647 . "Please report this to the dungeon master",
1648 cf::NDI_UNIQUE | cf::NDI_RED);
1649
1650 warn "ERROR in enter_exit: $@";
1651 $self->leave_link;
1652 }
1653 })->prio (1);
1654}
1655
1656=head3 cf::client
1657
1658=over 4
1659
1660=item $client->send_drawinfo ($text, $flags)
1661
1662Sends a drawinfo packet to the client. Circumvents output buffering so
1663should not be used under normal circumstances.
1664
1665=cut
1666
1667sub cf::client::send_drawinfo {
1668 my ($self, $text, $flags) = @_;
1669
1670 utf8::encode $text;
1671 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text);
1672}
1673
1674
1675=item $success = $client->query ($flags, "text", \&cb)
1676
1677Queues a query to the client, calling the given callback with
1678the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1679C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1680
1681Queries can fail, so check the return code. Or don't, as queries will become
1682reliable at some point in the future.
1683
1684=cut
1685
1686sub cf::client::query {
1687 my ($self, $flags, $text, $cb) = @_;
1688
1689 return unless $self->state == ST_PLAYING
1690 || $self->state == ST_SETUP
1691 || $self->state == ST_CUSTOM;
1692
1693 $self->state (ST_CUSTOM);
1694
1695 utf8::encode $text;
1696 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1697
1698 $self->send_packet ($self->{query_queue}[0][0])
1699 if @{ $self->{query_queue} } == 1;
1700}
1701
1702cf::client->attach (
1703 on_reply => sub {
1704 my ($ns, $msg) = @_;
1705
1706 # this weird shuffling is so that direct followup queries
1707 # get handled first
1708 my $queue = delete $ns->{query_queue};
1709
1710 (shift @$queue)->[1]->($msg);
1711
1712 push @{ $ns->{query_queue} }, @$queue;
1713
1714 if (@{ $ns->{query_queue} } == @$queue) {
1715 if (@$queue) {
1716 $ns->send_packet ($ns->{query_queue}[0][0]);
1717 } else {
1718 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1719 }
1720 }
1721 },
1722);
1723
1724=item $client->coro (\&cb)
1725
1726Create a new coroutine, running the specified callback. The coroutine will
1727be automatically cancelled when the client gets destroyed (e.g. on logout,
1728or loss of connection).
1729
1730=cut
1731
1732sub cf::client::coro {
1733 my ($self, $cb) = @_;
1734
1735 my $coro; $coro = async {
1736 eval {
1737 $cb->();
1738 };
1739 warn $@ if $@;
1740 };
1741
1742 $coro->on_destroy (sub {
1743 delete $self->{_coro}{$coro+0};
1744 });
1745
1746 $self->{_coro}{$coro+0} = $coro;
1747
1748 $coro
1749}
1750
1751cf::client->attach (
1752 on_destroy => sub {
1753 my ($ns) = @_;
1754
1755 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
1756 },
1757);
1758
1759=back
1760
1761
1762=head2 SAFE SCRIPTING
1763
1764Functions that provide a safe environment to compile and execute
1765snippets of perl code without them endangering the safety of the server
1766itself. Looping constructs, I/O operators and other built-in functionality
1767is not available in the safe scripting environment, and the number of
1768functions and methods that can be called is greatly reduced.
1769
1770=cut
845 1771
846our $safe = new Safe "safe"; 1772our $safe = new Safe "safe";
847our $safe_hole = new Safe::Hole; 1773our $safe_hole = new Safe::Hole;
848 1774
849$SIG{FPE} = 'IGNORE'; 1775$SIG{FPE} = 'IGNORE';
850 1776
851$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 1777$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
852 1778
853# here we export the classes and methods available to script code 1779# here we export the classes and methods available to script code
854 1780
1781=pod
1782
1783The following fucntions and emthods are available within a safe environment:
1784
1785 cf::object contr pay_amount pay_player map
1786 cf::object::player player
1787 cf::player peaceful
1788 cf::map trigger
1789
1790=cut
1791
855for ( 1792for (
856 ["cf::object" => qw(contr pay_amount pay_player)], 1793 ["cf::object" => qw(contr pay_amount pay_player map)],
857 ["cf::object::player" => qw(player)], 1794 ["cf::object::player" => qw(player)],
858 ["cf::player" => qw(peaceful)], 1795 ["cf::player" => qw(peaceful)],
1796 ["cf::map" => qw(trigger)],
859) { 1797) {
860 no strict 'refs'; 1798 no strict 'refs';
861 my ($pkg, @funs) = @$_; 1799 my ($pkg, @funs) = @$_;
862 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 1800 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
863 for @funs; 1801 for @funs;
864} 1802}
1803
1804=over 4
1805
1806=item @retval = safe_eval $code, [var => value, ...]
1807
1808Compiled and executes the given perl code snippet. additional var/value
1809pairs result in temporary local (my) scalar variables of the given name
1810that are available in the code snippet. Example:
1811
1812 my $five = safe_eval '$first + $second', first => 1, second => 4;
1813
1814=cut
865 1815
866sub safe_eval($;@) { 1816sub safe_eval($;@) {
867 my ($code, %vars) = @_; 1817 my ($code, %vars) = @_;
868 1818
869 my $qcode = $code; 1819 my $qcode = $code;
892 } 1842 }
893 1843
894 wantarray ? @res : $res[0] 1844 wantarray ? @res : $res[0]
895} 1845}
896 1846
1847=item cf::register_script_function $function => $cb
1848
1849Register a function that can be called from within map/npc scripts. The
1850function should be reasonably secure and should be put into a package name
1851like the extension.
1852
1853Example: register a function that gets called whenever a map script calls
1854C<rent::overview>, as used by the C<rent> extension.
1855
1856 cf::register_script_function "rent::overview" => sub {
1857 ...
1858 };
1859
1860=cut
1861
897sub register_script_function { 1862sub register_script_function {
898 my ($fun, $cb) = @_; 1863 my ($fun, $cb) = @_;
899 1864
900 no strict 'refs'; 1865 no strict 'refs';
901 *{"safe::$fun"} = $safe_hole->wrap ($cb); 1866 *{"safe::$fun"} = $safe_hole->wrap ($cb);
902} 1867}
903 1868
1869=back
1870
1871=cut
1872
1873#############################################################################
1874
1875=head2 EXTENSION DATABASE SUPPORT
1876
1877Crossfire maintains a very simple database for extension use. It can
1878currently store anything that can be serialised using Storable, which
1879excludes objects.
1880
1881The parameter C<$family> should best start with the name of the extension
1882using it, it should be unique.
1883
1884=over 4
1885
1886=item $hashref = cf::db_get $family
1887
1888Return a hashref for use by the extension C<$family>, which can be
1889modified. After modifications, you have to call C<cf::db_dirty> or
1890C<cf::db_sync>.
1891
1892=item $value = cf::db_get $family => $key
1893
1894Returns a single value from the database
1895
1896=item cf::db_put $family => $hashref
1897
1898Stores the given family hashref into the database. Updates are delayed, if
1899you want the data to be synced to disk immediately, use C<cf::db_sync>.
1900
1901=item cf::db_put $family => $key => $value
1902
1903Stores the given C<$value> in the family hash. Updates are delayed, if you
1904want the data to be synced to disk immediately, use C<cf::db_sync>.
1905
1906=item cf::db_dirty
1907
1908Marks the database as dirty, to be updated at a later time.
1909
1910=item cf::db_sync
1911
1912Immediately write the database to disk I<if it is dirty>.
1913
1914=cut
1915
1916our $DB;
1917
1918{
1919 my $path = cf::localdir . "/database.pst";
1920
1921 sub db_load() {
1922 $DB = stat $path ? Storable::retrieve $path : { };
1923 }
1924
1925 my $pid;
1926
1927 sub db_save() {
1928 waitpid $pid, 0 if $pid;
1929 if (0 == ($pid = fork)) {
1930 $DB->{_meta}{version} = 1;
1931 Storable::nstore $DB, "$path~";
1932 rename "$path~", $path;
1933 cf::_exit 0 if defined $pid;
1934 }
1935 }
1936
1937 my $dirty;
1938
1939 sub db_sync() {
1940 db_save if $dirty;
1941 undef $dirty;
1942 }
1943
1944 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1945 db_sync;
1946 });
1947
1948 sub db_dirty() {
1949 $dirty = 1;
1950 $idle->start;
1951 }
1952
1953 sub db_get($;$) {
1954 @_ >= 2
1955 ? $DB->{$_[0]}{$_[1]}
1956 : ($DB->{$_[0]} ||= { })
1957 }
1958
1959 sub db_put($$;$) {
1960 if (@_ >= 3) {
1961 $DB->{$_[0]}{$_[1]} = $_[2];
1962 } else {
1963 $DB->{$_[0]} = $_[1];
1964 }
1965 db_dirty;
1966 }
1967
1968 cf::global->attach (
1969 prio => 10000,
1970 on_cleanup => sub {
1971 db_sync;
1972 },
1973 );
1974}
1975
904############################################################################# 1976#############################################################################
905# the server's main() 1977# the server's main()
906 1978
1979sub cfg_load {
1980 open my $fh, "<:utf8", cf::confdir . "/config"
1981 or return;
1982
1983 local $/;
1984 *CFG = YAML::Syck::Load <$fh>;
1985}
1986
907sub main { 1987sub main {
1988 # we must not ever block the main coroutine
1989 local $Coro::idle = sub {
1990 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
1991 (Coro::unblock_sub {
1992 Event::one_event;
1993 })->();
1994 };
1995
1996 cfg_load;
1997 db_load;
1998 load_extensions;
908 Event::loop; 1999 Event::loop;
909} 2000}
910 2001
911############################################################################# 2002#############################################################################
912# initialisation 2003# initialisation
913 2004
2005sub reload() {
2006 # can/must only be called in main
2007 if ($Coro::current != $Coro::main) {
2008 warn "can only reload from main coroutine\n";
2009 return;
2010 }
2011
2012 warn "reloading...";
2013
2014 local $FREEZE = 1;
2015 cf::emergency_save;
2016
2017 eval {
2018 # if anything goes wrong in here, we should simply crash as we already saved
2019
2020 # cancel all watchers
2021 for (Event::all_watchers) {
2022 $_->cancel if $_->data & WF_AUTOCANCEL;
2023 }
2024
2025 # cancel all extension coros
2026 $_->cancel for values %EXT_CORO;
2027 %EXT_CORO = ();
2028
2029 # unload all extensions
2030 for (@exts) {
2031 warn "unloading <$_>";
2032 unload_extension $_;
2033 }
2034
2035 # unload all modules loaded from $LIBDIR
2036 while (my ($k, $v) = each %INC) {
2037 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2038
2039 warn "removing <$k>";
2040 delete $INC{$k};
2041
2042 $k =~ s/\.pm$//;
2043 $k =~ s/\//::/g;
2044
2045 if (my $cb = $k->can ("unload_module")) {
2046 $cb->();
2047 }
2048
2049 Symbol::delete_package $k;
2050 }
2051
2052 # sync database to disk
2053 cf::db_sync;
2054 IO::AIO::flush;
2055
2056 # get rid of safe::, as good as possible
2057 Symbol::delete_package "safe::$_"
2058 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2059
2060 # remove register_script_function callbacks
2061 # TODO
2062
2063 # unload cf.pm "a bit"
2064 delete $INC{"cf.pm"};
2065
2066 # don't, removes xs symbols, too,
2067 # and global variables created in xs
2068 #Symbol::delete_package __PACKAGE__;
2069
2070 # reload cf.pm
2071 warn "reloading cf.pm";
2072 require cf;
2073 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2074
2075 # load config and database again
2076 cf::cfg_load;
2077 cf::db_load;
2078
2079 # load extensions
2080 warn "load extensions";
2081 cf::load_extensions;
2082
2083 # reattach attachments to objects
2084 warn "reattach";
2085 _global_reattach;
2086 };
2087
2088 if ($@) {
2089 warn $@;
2090 warn "error while reloading, exiting.";
2091 exit 1;
2092 }
2093
2094 warn "reloaded successfully";
2095};
2096
2097#############################################################################
2098
2099unless ($LINK_MAP) {
2100 $LINK_MAP = cf::map::new;
2101
2102 $LINK_MAP->width (41);
2103 $LINK_MAP->height (41);
2104 $LINK_MAP->alloc;
2105 $LINK_MAP->path ("{link}");
2106 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2107 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2108
2109 # dirty hack because... archetypes are not yet loaded
2110 Event->timer (
2111 after => 2,
2112 cb => sub {
2113 $_[0]->w->cancel;
2114
2115 # provide some exits "home"
2116 my $exit = cf::object::new "exit";
2117
2118 $exit->slaying ($EMERGENCY_POSITION->[0]);
2119 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2120 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2121
2122 $LINK_MAP->insert ($exit->clone, 19, 19);
2123 $LINK_MAP->insert ($exit->clone, 19, 20);
2124 $LINK_MAP->insert ($exit->clone, 19, 21);
2125 $LINK_MAP->insert ($exit->clone, 20, 19);
2126 $LINK_MAP->insert ($exit->clone, 20, 21);
2127 $LINK_MAP->insert ($exit->clone, 21, 19);
2128 $LINK_MAP->insert ($exit->clone, 21, 20);
2129 $LINK_MAP->insert ($exit->clone, 21, 21);
2130
2131 $exit->destroy;
2132 });
2133
2134 $LINK_MAP->{deny_save} = 1;
2135 $LINK_MAP->{deny_reset} = 1;
2136
2137 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2138}
2139
914register "<global>", __PACKAGE__; 2140register "<global>", __PACKAGE__;
915 2141
2142register_command "reload" => sub {
2143 my ($who, $arg) = @_;
2144
2145 if ($who->flag (FLAG_WIZ)) {
2146 $who->message ("start of reload.");
2147 reload;
2148 $who->message ("end of reload.");
2149 }
2150};
2151
916unshift @INC, $LIBDIR; 2152unshift @INC, $LIBDIR;
917 2153
918load_extensions;
919
920$TICK_WATCHER = Event->timer ( 2154$TICK_WATCHER = Event->timer (
2155 reentrant => 0,
921 prio => 1, 2156 prio => 0,
922 at => $NEXT_TICK || 1, 2157 at => $NEXT_TICK || $TICK,
2158 data => WF_AUTOCANCEL,
923 cb => sub { 2159 cb => sub {
2160 unless ($FREEZE) {
924 cf::server_tick; # one server iteration 2161 cf::server_tick; # one server iteration
2162 $RUNTIME += $TICK;
2163 }
925 2164
926 my $NOW = Event::time;
927 $NEXT_TICK += $TICK; 2165 $NEXT_TICK += $TICK;
928 2166
929 # if we are delayed by four ticks, skip them all 2167 # if we are delayed by four ticks or more, skip them all
930 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 2168 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
931 2169
932 $TICK_WATCHER->at ($NEXT_TICK); 2170 $TICK_WATCHER->at ($NEXT_TICK);
933 $TICK_WATCHER->start; 2171 $TICK_WATCHER->start;
934 }, 2172 },
935); 2173);
936 2174
937_reload_2; 2175IO::AIO::max_poll_time $TICK * 0.2;
2176
2177Event->io (
2178 fd => IO::AIO::poll_fileno,
2179 poll => 'r',
2180 prio => 5,
2181 data => WF_AUTOCANCEL,
2182 cb => \&IO::AIO::poll_cb,
2183);
2184
2185Event->timer (
2186 data => WF_AUTOCANCEL,
2187 after => 0,
2188 interval => 10,
2189 cb => sub {
2190 (Coro::unblock_sub {
2191 write_runtime
2192 or warn "ERROR: unable to write runtime file: $!";
2193 })->();
2194 },
2195);
2196
2197END { cf::emergency_save }
938 2198
9391 21991
940 2200

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines