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.128 by root, Wed Jan 3 00:28:47 2007 UTC vs.
Revision 1.452 by root, Tue Sep 23 00:24:52 2008 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation, either version 3 of the License, or
9# (at your option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>.
18#
19# The authors can be reached via e-mail to <support@deliantra.net>
20#
21
1package cf; 22package cf;
2 23
24use 5.10.0;
3use utf8; 25use utf8;
4use strict; 26use strict "vars", "subs";
5 27
6use Symbol; 28use Symbol;
7use List::Util; 29use List::Util;
8use Storable; 30use Socket;
31use EV;
9use Opcode; 32use Opcode;
10use Safe; 33use Safe;
11use Safe::Hole; 34use Safe::Hole;
35use Storable ();
12 36
13use Coro 3.3 (); 37use Coro ();
38use Coro::State;
39use Coro::Handle;
40use Coro::EV;
14use Coro::Event; 41use Coro::AnyEvent;
15use Coro::Timer; 42use Coro::Timer;
16use Coro::Signal; 43use Coro::Signal;
17use Coro::Semaphore; 44use Coro::Semaphore;
45use Coro::AnyEvent;
18use Coro::AIO; 46use Coro::AIO;
47use Coro::BDB 1.6;
48use Coro::Storable;
49use Coro::Util ();
19 50
51use JSON::XS 2.01 ();
52use BDB ();
53use Data::Dumper;
20use Digest::MD5; 54use Digest::MD5;
21use Fcntl; 55use Fcntl;
56use YAML ();
22use IO::AIO 2.31 (); 57use IO::AIO ();
23use YAML::Syck ();
24use Time::HiRes; 58use Time::HiRes;
59use Compress::LZF;
60use Digest::MD5 ();
25 61
26use Event; $Event::Eval = 1; # no idea why this is required, but it is 62AnyEvent::detect;
27 63
28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 64# configure various modules to our taste
29$YAML::Syck::ImplicitUnicode = 1; 65#
66$Storable::canonical = 1; # reduce rsync transfers
67Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
30 68
31$Coro::main->prio (2); # run main coroutine ("the server") with very high priority 69$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
70
71# make sure c-lzf reinitialises itself
72Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
73Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
32 74
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 75sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34 76
35our %COMMAND = (); 77our %COMMAND = ();
36our %COMMAND_TIME = (); 78our %COMMAND_TIME = ();
79
80our @EXTS = (); # list of extension package names
37our %EXTCMD = (); 81our %EXTCMD = ();
82our %EXTICMD = ();
83our %EXT_CORO = (); # coroutines bound to extensions
84our %EXT_MAP = (); # pluggable maps
38 85
86our $RELOAD; # number of reloads so far, non-zero while in reload
39our @EVENT; 87our @EVENT;
40our $LIBDIR = datadir . "/ext";
41 88
42our $TICK = MAX_TIME * 1e-6; 89our $CONFDIR = confdir;
43our $TICK_WATCHER; 90our $DATADIR = datadir;
91our $LIBDIR = "$DATADIR/ext";
92our $PODDIR = "$DATADIR/pod";
93our $MAPDIR = "$DATADIR/" . mapdir;
94our $LOCALDIR = localdir;
95our $TMPDIR = "$LOCALDIR/" . tmpdir;
96our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
97our $PLAYERDIR = "$LOCALDIR/" . playerdir;
98our $RANDOMDIR = "$LOCALDIR/random";
99our $BDBDIR = "$LOCALDIR/db";
100our $PIDFILE = "$LOCALDIR/pid";
101our $RUNTIMEFILE = "$LOCALDIR/runtime";
102
103our %RESOURCE;
104
105our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
106our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
44our $NEXT_TICK; 107our $NEXT_TICK;
45our $NOW; 108our $USE_FSYNC = 1; # use fsync to write maps - default off
109
110our $BDB_DEADLOCK_WATCHER;
111our $BDB_CHECKPOINT_WATCHER;
112our $BDB_TRICKLE_WATCHER;
113our $DB_ENV;
46 114
47our %CFG; 115our %CFG;
48 116
49our $UPTIME; $UPTIME ||= time; 117our $UPTIME; $UPTIME ||= time;
50our $RUNTIME; 118our $RUNTIME;
119our $NOW;
51 120
52our %MAP; # all maps 121our (%PLAYER, %PLAYER_LOADING); # all users
53our $LINK_MAP; # the special {link} map 122our (%MAP, %MAP_LOADING ); # all maps
54our $FREEZE; 123our $LINK_MAP; # the special {link} map, which is always available
55our $RANDOM_MAPS = cf::localdir . "/random"; 124
56our %EXT_CORO; 125# used to convert map paths into valid unix filenames by replacing / by ∕
126our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
127
128our $LOAD; # a number between 0 (idle) and 1 (too many objects)
129our $LOADAVG; # same thing, but with alpha-smoothing
130our $JITTER; # average jitter
131our $TICK_START; # for load detecting purposes
57 132
58binmode STDOUT; 133binmode STDOUT;
59binmode STDERR; 134binmode STDERR;
60 135
61# read virtual server time, if available 136# read virtual server time, if available
62unless ($RUNTIME || !-e cf::localdir . "/runtime") { 137unless ($RUNTIME || !-e $RUNTIMEFILE) {
63 open my $fh, "<", cf::localdir . "/runtime" 138 open my $fh, "<", $RUNTIMEFILE
64 or die "unable to read runtime file: $!"; 139 or die "unable to read $RUNTIMEFILE file: $!";
65 $RUNTIME = <$fh> + 0.; 140 $RUNTIME = <$fh> + 0.;
66} 141}
67 142
68mkdir cf::localdir; 143mkdir $_
69mkdir cf::localdir . "/" . cf::playerdir; 144 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
70mkdir cf::localdir . "/" . cf::tmpdir;
71mkdir cf::localdir . "/" . cf::uniquedir;
72mkdir $RANDOM_MAPS;
73 145
74# a special map that is always available 146our $EMERGENCY_POSITION;
75our $LINK_MAP;
76 147
77our $EMERGENCY_POSITION = $cf::CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 148sub cf::map::normalise;
78 149
79############################################################################# 150#############################################################################
80 151
81=head2 GLOBAL VARIABLES 152=head2 GLOBAL VARIABLES
82 153
89=item $cf::RUNTIME 160=item $cf::RUNTIME
90 161
91The time this server has run, starts at 0 and is increased by $cf::TICK on 162The time this server has run, starts at 0 and is increased by $cf::TICK on
92every server tick. 163every server tick.
93 164
94=item $cf::LIBDIR 165=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
166$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
167$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
95 168
96The perl library directory, where extensions and cf-specific modules can 169Various directories - "/etc", read-only install directory, perl-library
97be found. It will be added to C<@INC> automatically. 170directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
171unique-items directory, player file directory, random maps directory and
172database environment.
98 173
99=item $cf::NOW 174=item $cf::NOW
100 175
101The time of the last (current) server tick. 176The time of the last (current) server tick.
102 177
103=item $cf::TICK 178=item $cf::TICK
104 179
105The interval between server ticks, in seconds. 180The interval between server ticks, in seconds.
106 181
182=item $cf::LOADAVG
183
184The current CPU load on the server (alpha-smoothed), as a value between 0
185(none) and 1 (overloaded), indicating how much time is spent on processing
186objects per tick. Healthy values are < 0.5.
187
188=item $cf::LOAD
189
190The raw value load value from the last tick.
191
107=item %cf::CFG 192=item %cf::CFG
108 193
109Configuration for the server, loaded from C</etc/crossfire/config>, or 194Configuration for the server, loaded from C</etc/deliantra-server/config>, or
110from wherever your confdir points to. 195from wherever your confdir points to.
196
197=item cf::wait_for_tick, cf::wait_for_tick_begin
198
199These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
200returns directly I<after> the tick processing (and consequently, can only wake one process
201per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
202
203=item @cf::INVOKE_RESULTS
204
205This array contains the results of the last C<invoke ()> call. When
206C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
207that call.
111 208
112=back 209=back
113 210
114=cut 211=cut
115 212
116BEGIN { 213BEGIN {
117 *CORE::GLOBAL::warn = sub { 214 *CORE::GLOBAL::warn = sub {
118 my $msg = join "", @_; 215 my $msg = join "", @_;
119 utf8::encode $msg;
120 216
121 $msg .= "\n" 217 $msg .= "\n"
122 unless $msg =~ /\n$/; 218 unless $msg =~ /\n$/;
123 219
220 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
221
124 LOG llevError, "cfperl: $msg"; 222 LOG llevError, $msg;
125 }; 223 };
126} 224}
225
226$Coro::State::DIEHOOK = sub {
227 return unless $^S eq 0; # "eq", not "=="
228
229 if ($Coro::current == $Coro::main) {#d#
230 warn "DIEHOOK called in main context, Coro bug?\n";#d#
231 return;#d#
232 }#d#
233
234 # kill coroutine otherwise
235 warn Carp::longmess $_[0];
236 Coro::terminate
237};
238
239$SIG{__DIE__} = sub { }; #d#?
127 240
128@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 241@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
129@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 242@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
130@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 243@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
131@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 244@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
132@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 245@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
246@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
133@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 247@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
134 248
135# we bless all objects into (empty) derived classes to force a method lookup 249# we bless all objects into (empty) derived classes to force a method lookup
136# within the Safe compartment. 250# within the Safe compartment.
137for my $pkg (qw( 251for my $pkg (qw(
138 cf::global cf::attachable 252 cf::global cf::attachable
139 cf::object cf::object::player 253 cf::object cf::object::player
140 cf::client cf::player 254 cf::client cf::player
141 cf::arch cf::living 255 cf::arch cf::living
256 cf::map cf::mapspace
142 cf::map cf::party cf::region 257 cf::party cf::region
143)) { 258)) {
144 no strict 'refs';
145 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 259 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
146} 260}
147 261
148$Event::DIED = sub { 262$EV::DIED = sub {
149 warn "error in event callback: @_"; 263 warn "error in event callback: @_";
150}; 264};
151 265
152my %ext_pkg; 266#############################################################################
153my @exts;
154my @hook;
155 267
156=head2 UTILITY FUNCTIONS 268=head2 UTILITY FUNCTIONS
157 269
158=over 4 270=over 4
159 271
160=cut 272=item dumpval $ref
161 273
162use JSON::Syck (); # TODO# replace by JSON::PC once working 274=cut
163 275
276sub dumpval {
277 eval {
278 local $SIG{__DIE__};
279 my $d;
280 if (1) {
281 $d = new Data::Dumper([$_[0]], ["*var"]);
282 $d->Terse(1);
283 $d->Indent(2);
284 $d->Quotekeys(0);
285 $d->Useqq(1);
286 #$d->Bless(...);
287 $d->Seen($_[1]) if @_ > 1;
288 $d = $d->Dump();
289 }
290 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
291 $d
292 } || "[unable to dump $_[0]: '$@']";
293}
294
164=item $ref = cf::from_json $json 295=item $ref = cf::decode_json $json
165 296
166Converts a JSON string into the corresponding perl data structure. 297Converts a JSON string into the corresponding perl data structure.
167 298
168=cut
169
170sub from_json($) {
171 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
172 JSON::Syck::Load $_[0]
173}
174
175=item $json = cf::to_json $ref 299=item $json = cf::encode_json $ref
176 300
177Converts a perl data structure into its JSON representation. 301Converts a perl data structure into its JSON representation.
178 302
179=cut 303=cut
180 304
181sub to_json($) { 305our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
182 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
183 JSON::Syck::Dump $_[0]
184}
185 306
186=item my $guard = cf::guard { BLOCK } 307sub encode_json($) { $json_coder->encode ($_[0]) }
187 308sub decode_json($) { $json_coder->decode ($_[0]) }
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 309
208=item cf::lock_wait $string 310=item cf::lock_wait $string
209 311
210Wait until the given lock is available. See cf::lock_acquire. 312Wait until the given lock is available. See cf::lock_acquire.
211 313
212=item my $lock = cf::lock_acquire $string 314=item my $lock = cf::lock_acquire $string
213 315
214Wait until the given lock is available and then acquires it and returns 316Wait 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, 317a Coro::guard object. If the guard object gets destroyed (goes out of scope,
216for example when the coroutine gets canceled), the lock is automatically 318for example when the coroutine gets canceled), the lock is automatically
217returned. 319returned.
218 320
321Locks are *not* recursive, locking from the same coro twice results in a
322deadlocked coro.
323
219Lock names should begin with a unique identifier (for example, find_map 324Lock names should begin with a unique identifier (for example, cf::map::find
220uses map_find and load_map uses map_load). 325uses map_find and cf::map::load uses map_load).
326
327=item $locked = cf::lock_active $string
328
329Return true if the lock is currently active, i.e. somebody has locked it.
221 330
222=cut 331=cut
223 332
224our %LOCK; 333our %LOCK;
334our %LOCKER;#d#
225 335
226sub lock_wait($) { 336sub lock_wait($) {
227 my ($key) = @_; 337 my ($key) = @_;
228 338
339 if ($LOCKER{$key} == $Coro::current) {#d#
340 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
341 return;#d#
342 }#d#
343
229 # wait for lock, if any 344 # wait for lock, if any
230 while ($LOCK{$key}) { 345 while ($LOCK{$key}) {
346 #local $Coro::current->{desc} = "$Coro::current->{desc} <waiting for lock $key>";
231 push @{ $LOCK{$key} }, $Coro::current; 347 push @{ $LOCK{$key} }, $Coro::current;
232 Coro::schedule; 348 Coro::schedule;
233 } 349 }
234} 350}
235 351
238 354
239 # wait, to be sure we are not locked 355 # wait, to be sure we are not locked
240 lock_wait $key; 356 lock_wait $key;
241 357
242 $LOCK{$key} = []; 358 $LOCK{$key} = [];
359 $LOCKER{$key} = $Coro::current;#d#
243 360
244 cf::guard { 361 Coro::guard {
362 delete $LOCKER{$key};#d#
245 # wake up all waiters, to be on the safe side 363 # wake up all waiters, to be on the safe side
246 $_->ready for @{ delete $LOCK{$key} }; 364 $_->ready for @{ delete $LOCK{$key} };
247 } 365 }
248} 366}
249 367
368sub lock_active($) {
369 my ($key) = @_;
370
371 ! ! $LOCK{$key}
372}
373
374sub freeze_mainloop {
375 tick_inhibit_inc;
376
377 Coro::guard \&tick_inhibit_dec;
378}
379
380=item cf::periodic $interval, $cb
381
382Like EV::periodic, but randomly selects a starting point so that the actions
383get spread over timer.
384
385=cut
386
387sub periodic($$) {
388 my ($interval, $cb) = @_;
389
390 my $start = rand List::Util::min 180, $interval;
391
392 EV::periodic $start, $interval, 0, $cb
393}
394
395=item cf::get_slot $time[, $priority[, $name]]
396
397Allocate $time seconds of blocking CPU time at priority C<$priority>:
398This call blocks and returns only when you have at least C<$time> seconds
399of cpu time till the next tick. The slot is only valid till the next cede.
400
401The optional C<$name> can be used to identify the job to run. It might be
402used for statistical purposes and should identify the same time-class.
403
404Useful for short background jobs.
405
406=cut
407
408our @SLOT_QUEUE;
409our $SLOT_QUEUE;
410
411$SLOT_QUEUE->cancel if $SLOT_QUEUE;
412$SLOT_QUEUE = Coro::async {
413 $Coro::current->desc ("timeslot manager");
414
415 my $signal = new Coro::Signal;
416
417 while () {
418 next_job:
419 my $avail = cf::till_tick;
420 if ($avail > 0.01) {
421 for (0 .. $#SLOT_QUEUE) {
422 if ($SLOT_QUEUE[$_][0] < $avail) {
423 my $job = splice @SLOT_QUEUE, $_, 1, ();
424 $job->[2]->send;
425 Coro::cede;
426 goto next_job;
427 }
428 }
429 }
430
431 if (@SLOT_QUEUE) {
432 # we do not use wait_for_tick() as it returns immediately when tick is inactive
433 push @cf::WAIT_FOR_TICK, $signal;
434 $signal->wait;
435 } else {
436 Coro::schedule;
437 }
438 }
439};
440
441sub get_slot($;$$) {
442 return if tick_inhibit || $Coro::current == $Coro::main;
443
444 my ($time, $pri, $name) = @_;
445
446 $time = $TICK * .6 if $time > $TICK * .6;
447 my $sig = new Coro::Signal;
448
449 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
450 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
451 $SLOT_QUEUE->ready;
452 $sig->wait;
453}
454
250=item cf::async { BLOCK } 455=item cf::async { BLOCK }
251 456
252Like C<Coro::async>, but runs the given BLOCK in an eval and only logs the 457Currently the same as Coro::async_pool, meaning you cannot use
253error instead of exiting the server in case of a problem. 458C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
459thing you are allowed to do is call C<prio> on it.
254 460
255=cut 461=cut
256 462
257sub async(&) { 463BEGIN { *async = \&Coro::async_pool }
258 my ($cb) = @_;
259
260 Coro::async {
261 eval { $cb->() };
262 warn $@ if $@;
263 }
264}
265 464
266=item cf::sync_job { BLOCK } 465=item cf::sync_job { BLOCK }
267 466
268The design of crossfire+ requires that the main coro ($Coro::main) is 467The design of Deliantra requires that the main coroutine ($Coro::main)
269always able to handle events or runnable, as crossfire+ is only partly 468is always able to handle events or runnable, as Deliantra is only
270reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 469partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
470acceptable.
271 471
272If it must be done, put the blocking parts into C<sync_job>. This will run 472If it must be done, put the blocking parts into C<sync_job>. This will run
273the given BLOCK in another coroutine while waiting for the result. The 473the given BLOCK in another coroutine while waiting for the result. The
274server will be frozen during this time, so the block should either finish 474server will be frozen during this time, so the block should either finish
275fast or be very important. 475fast or be very important.
278 478
279sub sync_job(&) { 479sub sync_job(&) {
280 my ($job) = @_; 480 my ($job) = @_;
281 481
282 if ($Coro::current == $Coro::main) { 482 if ($Coro::current == $Coro::main) {
483 my $time = EV::time;
484
283 # this is the main coro, too bad, we have to block 485 # this is the main coro, too bad, we have to block
284 # till the operation succeeds, freezing the server :/ 486 # till the operation succeeds, freezing the server :/
285 487
286 # TODO: use suspend/resume instead 488 LOG llevError, Carp::longmess "sync job";#d#
287 # (but this is cancel-safe) 489
288 local $FREEZE = 1; 490 my $freeze_guard = freeze_mainloop;
289 491
290 my $busy = 1; 492 my $busy = 1;
291 my @res; 493 my @res;
292 494
293 (Coro::async { 495 (async {
496 $Coro::current->desc ("sync job coro");
294 @res = eval { $job->() }; 497 @res = eval { $job->() };
295 warn $@ if $@; 498 warn $@ if $@;
296 undef $busy; 499 undef $busy;
297 })->prio (Coro::PRIO_MAX); 500 })->prio (Coro::PRIO_MAX);
298 501
299 while ($busy) { 502 while ($busy) {
503 if (Coro::nready) {
300 Coro::cede_notself; 504 Coro::cede_notself;
301 Event::one_event unless Coro::nready; 505 } else {
506 EV::loop EV::LOOP_ONESHOT;
302 } 507 }
508 }
509
510 my $time = EV::time - $time;
511
512 $TICK_START += $time; # do not account sync jobs to server load
303 513
304 wantarray ? @res : $res[0] 514 wantarray ? @res : $res[0]
305 } else { 515 } else {
306 # we are in another coroutine, how wonderful, everything just works 516 # we are in another coroutine, how wonderful, everything just works
307 517
308 $job->() 518 $job->()
309 } 519 }
310} 520}
311 521
312=item $coro = cf::coro { BLOCK } 522=item $coro = cf::async_ext { BLOCK }
313 523
314Creates and returns a new coro. This coro is automcatially being canceled 524Like async, but this coro is automatically being canceled when the
315when the extension calling this is being unloaded. 525extension calling this is being unloaded.
316 526
317=cut 527=cut
318 528
319sub coro(&) { 529sub async_ext(&) {
320 my $cb = shift; 530 my $cb = shift;
321 531
322 my $coro = &cf::async ($cb); 532 my $coro = &Coro::async ($cb);
323 533
324 $coro->on_destroy (sub { 534 $coro->on_destroy (sub {
325 delete $EXT_CORO{$coro+0}; 535 delete $EXT_CORO{$coro+0};
326 }); 536 });
327 $EXT_CORO{$coro+0} = $coro; 537 $EXT_CORO{$coro+0} = $coro;
328 538
329 $coro 539 $coro
330} 540}
331 541
332sub write_runtime { 542=item fork_call { }, $args
333 my $runtime = cf::localdir . "/runtime";
334 543
335 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 544Executes the given code block with the given arguments in a seperate
336 or return; 545process, returning the results. Everything must be serialisable with
546Coro::Storable. May, of course, block. Note that the executed sub may
547never block itself or use any form of event handling.
337 548
338 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock 549=cut
339 (aio_write $fh, 0, (length $value), $value, 0) <= 0
340 and return;
341 550
342 aio_fsync $fh 551sub fork_call(&@) {
343 and return; 552 my ($cb, @args) = @_;
344 553
345 close $fh 554 # we seemingly have to make a local copy of the whole thing,
346 or return; 555 # otherwise perl prematurely frees the stuff :/
556 # TODO: investigate and fix (likely this will be rather laborious)
347 557
348 aio_rename "$runtime~", $runtime 558 my @res = Coro::Util::fork_eval {
349 and return; 559 reset_signals;
560 &$cb
561 }, @args;
350 562
563 wantarray ? @res : $res[-1]
564}
565
566=item $coin = coin_from_name $name
567
568=cut
569
570our %coin_alias = (
571 "silver" => "silvercoin",
572 "silvercoin" => "silvercoin",
573 "silvercoins" => "silvercoin",
574 "gold" => "goldcoin",
575 "goldcoin" => "goldcoin",
576 "goldcoins" => "goldcoin",
577 "platinum" => "platinacoin",
578 "platinumcoin" => "platinacoin",
579 "platinumcoins" => "platinacoin",
580 "platina" => "platinacoin",
581 "platinacoin" => "platinacoin",
582 "platinacoins" => "platinacoin",
583 "royalty" => "royalty",
584 "royalties" => "royalty",
585);
586
587sub coin_from_name($) {
588 $coin_alias{$_[0]}
589 ? cf::arch::find $coin_alias{$_[0]}
590 : undef
591}
592
593=item $value = cf::db_get $family => $key
594
595Returns a single value from the environment database.
596
597=item cf::db_put $family => $key => $value
598
599Stores the given C<$value> in the family. It can currently store binary
600data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
601
602=item $db = cf::db_table "name"
603
604Create and/or open a new database table. The string must not be "db" and must be unique
605within each server.
606
607=cut
608
609sub db_table($) {
610 my ($name) = @_;
611 my $db = BDB::db_create $DB_ENV;
612
613 eval {
614 $db->set_flags (BDB::CHKSUM);
615
616 utf8::encode $name;
617 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
618 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
619 cf::cleanup "db_open(db): $!" if $!;
620 };
621 cf::cleanup "db_open(db): $@" if $@;
622
623 $db
624}
625
626our $DB;
627
628sub db_init {
629 cf::sync_job {
630 $DB ||= db_table "db";
631 };
632}
633
634sub db_get($$) {
635 my $key = "$_[0]/$_[1]";
636
637 cf::sync_job {
638 BDB::db_get $DB, undef, $key, my $data;
639
640 $! ? ()
641 : $data
351 1 642 }
643}
644
645sub db_put($$$) {
646 BDB::dbreq_pri 4;
647 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
648}
649
650=item cf::cache $id => [$paths...], $processversion => $process
651
652Generic caching function that returns the value of the resource $id,
653caching and regenerating as required.
654
655This function can block.
656
657=cut
658
659sub cache {
660 my ($id, $src, $processversion, $process) = @_;
661
662 my $meta =
663 join "\x00",
664 $processversion,
665 map {
666 aio_stat $_
667 and Carp::croak "$_: $!";
668
669 ($_, (stat _)[7,9])
670 } @$src;
671
672 my $dbmeta = db_get cache => "$id/meta";
673 if ($dbmeta ne $meta) {
674 # changed, we may need to process
675
676 my @data;
677 my $md5;
678
679 for (0 .. $#$src) {
680 0 <= aio_load $src->[$_], $data[$_]
681 or Carp::croak "$src->[$_]: $!";
682 }
683
684 # if processing is expensive, check
685 # checksum first
686 if (1) {
687 $md5 =
688 join "\x00",
689 $processversion,
690 map {
691 cf::cede_to_tick;
692 ($src->[$_], Digest::MD5::md5_hex $data[$_])
693 } 0.. $#$src;
694
695
696 my $dbmd5 = db_get cache => "$id/md5";
697 if ($dbmd5 eq $md5) {
698 db_put cache => "$id/meta", $meta;
699
700 return db_get cache => "$id/data";
701 }
702 }
703
704 my $t1 = Time::HiRes::time;
705 my $data = $process->(\@data);
706 my $t2 = Time::HiRes::time;
707
708 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
709
710 db_put cache => "$id/data", $data;
711 db_put cache => "$id/md5" , $md5;
712 db_put cache => "$id/meta", $meta;
713
714 return $data;
715 }
716
717 db_get cache => "$id/data"
718}
719
720=item cf::datalog type => key => value, ...
721
722Log a datalog packet of the given type with the given key-value pairs.
723
724=cut
725
726sub datalog($@) {
727 my ($type, %kv) = @_;
728 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
352} 729}
353 730
354=back 731=back
355 732
356=cut 733=cut
357 734
358############################################################################# 735#############################################################################
359 736
360package cf::path;
361
362sub new {
363 my ($class, $path, $base) = @_;
364
365 $path = $path->as_string if ref $path;
366
367 my $self = bless { }, $class;
368
369 # {... are special paths that are not touched
370 # ?xxx/... are special absolute paths
371 # ?random/... random maps
372 # /! non-realised random map exit
373 # /... normal maps
374 # ~/... per-player maps without a specific player (DO NOT USE)
375 # ~user/... per-player map of a specific user
376
377 if ($path =~ /^{/) {
378 # fine as it is
379 } elsif ($path =~ s{^\?random/}{}) {
380 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
381 $self->{random} = cf::from_json $data;
382 } else {
383 if ($path =~ s{^~([^/]+)?}{}) {
384 $self->{user_rel} = 1;
385
386 if (defined $1) {
387 $self->{user} = $1;
388 } elsif ($base =~ m{^~([^/]+)/}) {
389 $self->{user} = $1;
390 } else {
391 warn "cannot resolve user-relative path without user <$path,$base>\n";
392 }
393 } elsif ($path =~ /^\//) {
394 # already absolute
395 } else {
396 $base =~ s{[^/]+/?$}{};
397 return $class->new ("$base/$path");
398 }
399
400 for ($path) {
401 redo if s{/\.?/}{/};
402 redo if s{/[^/]+/\.\./}{/};
403 }
404 }
405
406 $self->{path} = $path;
407
408 $self
409}
410
411# the name / primary key / in-game path
412sub as_string {
413 my ($self) = @_;
414
415 $self->{user_rel} ? "~$self->{user}$self->{path}"
416 : $self->{random} ? "?random/$self->{path}"
417 : $self->{path}
418}
419
420# the displayed name, this is a one way mapping
421sub visible_name {
422 my ($self) = @_;
423
424# if (my $rmp = $self->{random}) {
425# # todo: be more intelligent about this
426# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
427# } else {
428 $self->as_string
429# }
430}
431
432# escape the /'s in the path
433sub _escaped_path {
434 # ∕ is U+2215
435 (my $path = $_[0]{path}) =~ s/\//∕/g;
436 $path
437}
438
439# the original (read-only) location
440sub load_path {
441 my ($self) = @_;
442
443 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
444}
445
446# the temporary/swap location
447sub save_path {
448 my ($self) = @_;
449
450 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
451 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
452 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
453}
454
455# the unique path, might be eq to save_path
456sub uniq_path {
457 my ($self) = @_;
458
459 $self->{user_rel} || $self->{random}
460 ? undef
461 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
462}
463
464# return random map parameters, or undef
465sub random_map_params {
466 my ($self) = @_;
467
468 $self->{random}
469}
470
471# this is somewhat ugly, but style maps do need special treatment
472sub is_style_map {
473 $_[0]{path} =~ m{^/styles/}
474}
475
476package cf;
477
478#############################################################################
479
480=head2 ATTACHABLE OBJECTS 737=head2 ATTACHABLE OBJECTS
481 738
482Many objects in crossfire are so-called attachable objects. That means you can 739Many objects in deliantra are so-called attachable objects. That means you can
483attach callbacks/event handlers (a collection of which is called an "attachment") 740attach callbacks/event handlers (a collection of which is called an "attachment")
484to it. All such attachable objects support the following methods. 741to it. All such attachable objects support the following methods.
485 742
486In the following description, CLASS can be any of C<global>, C<object> 743In the following description, CLASS can be any of C<global>, C<object>
487C<player>, C<client> or C<map> (i.e. the attachable objects in 744C<player>, C<client> or C<map> (i.e. the attachable objects in
488crossfire+). 745Deliantra).
489 746
490=over 4 747=over 4
491 748
492=item $attachable->attach ($attachment, key => $value...) 749=item $attachable->attach ($attachment, key => $value...)
493 750
537=item cf::CLASS::attachment $name, ... 794=item cf::CLASS::attachment $name, ...
538 795
539Register an attachment by C<$name> through which attachable objects of the 796Register an attachment by C<$name> through which attachable objects of the
540given CLASS can refer to this attachment. 797given CLASS can refer to this attachment.
541 798
542Some classes such as crossfire maps and objects can specify attachments 799Some classes such as deliantra maps and objects can specify attachments
543that are attached at load/instantiate time, thus the need for a name. 800that are attached at load/instantiate time, thus the need for a name.
544 801
545These calls expect any number of the following handler/hook descriptions: 802These calls expect any number of the following handler/hook descriptions:
546 803
547=over 4 804=over 4
607our @CB_TYPE = (); # registry for type (cf-object class) based events 864our @CB_TYPE = (); # registry for type (cf-object class) based events
608our @CB_MAP = (); 865our @CB_MAP = ();
609 866
610my %attachment; 867my %attachment;
611 868
869sub cf::attachable::thawer_merge {
870 # simply override everything except _meta
871 local $_[0]{_meta};
872 %{$_[0]} = %{$_[1]};
873}
874
612sub _attach_cb($$$$) { 875sub _attach_cb($$$$) {
613 my ($registry, $event, $prio, $cb) = @_; 876 my ($registry, $event, $prio, $cb) = @_;
614 877
615 use sort 'stable'; 878 use sort 'stable';
616 879
650 $registry = $CB_TYPE[$object_type] ||= []; 913 $registry = $CB_TYPE[$object_type] ||= [];
651 914
652 } elsif ($type eq "subtype") { 915 } elsif ($type eq "subtype") {
653 defined $object_type or Carp::croak "subtype specified without type"; 916 defined $object_type or Carp::croak "subtype specified without type";
654 my $object_subtype = shift @arg; 917 my $object_subtype = shift @arg;
655 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 918 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
656 919
657 } elsif ($type eq "package") { 920 } elsif ($type eq "package") {
658 my $pkg = shift @arg; 921 my $pkg = shift @arg;
659 922
660 while (my ($name, $id) = each %cb_id) { 923 while (my ($name, $id) = each %cb_id) {
689 _attach $registry, $klass, @attach; 952 _attach $registry, $klass, @attach;
690 } 953 }
691 954
692 $obj->{$name} = \%arg; 955 $obj->{$name} = \%arg;
693 } else { 956 } else {
694 warn "object uses attachment '$name' that is not available, postponing.\n"; 957 warn "object uses attachment '$name' which is not available, postponing.\n";
695 } 958 }
696 959
697 $obj->{_attachment}{$name} = undef; 960 $obj->{_attachment}{$name} = undef;
698} 961}
699 962
701 if (ref $_[0]) { 964 if (ref $_[0]) {
702 _object_attach @_; 965 _object_attach @_;
703 } else { 966 } else {
704 _attach shift->_attach_registry, @_; 967 _attach shift->_attach_registry, @_;
705 } 968 }
969 _recalc_want;
706}; 970};
707 971
708# all those should be optimised 972# all those should be optimised
709sub cf::attachable::detach { 973sub cf::attachable::detach {
710 my ($obj, $name) = @_; 974 my ($obj, $name) = @_;
713 delete $obj->{_attachment}{$name}; 977 delete $obj->{_attachment}{$name};
714 reattach ($obj); 978 reattach ($obj);
715 } else { 979 } else {
716 Carp::croak "cannot, currently, detach class attachments"; 980 Carp::croak "cannot, currently, detach class attachments";
717 } 981 }
982 _recalc_want;
718}; 983};
719 984
720sub cf::attachable::attached { 985sub cf::attachable::attached {
721 my ($obj, $name) = @_; 986 my ($obj, $name) = @_;
722 987
737 "; 1002 ";
738 die if $@; 1003 die if $@;
739} 1004}
740 1005
741our $override; 1006our $override;
742our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 1007our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
743 1008
744sub override { 1009sub override {
745 $override = 1; 1010 $override = 1;
746 @invoke_results = (); 1011 @INVOKE_RESULTS = (@_);
747} 1012}
748 1013
749sub do_invoke { 1014sub do_invoke {
750 my $event = shift; 1015 my $event = shift;
751 my $callbacks = shift; 1016 my $callbacks = shift;
752 1017
753 @invoke_results = (); 1018 @INVOKE_RESULTS = ();
754 1019
755 local $override; 1020 local $override;
756 1021
757 for (@$callbacks) { 1022 for (@$callbacks) {
758 eval { &{$_->[1]} }; 1023 eval { &{$_->[1]} };
767 } 1032 }
768 1033
769 0 1034 0
770} 1035}
771 1036
772=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1037=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
773 1038
774=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1039=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
775 1040
776Generate an object-specific event with the given arguments. 1041Generate an object-specific event with the given arguments.
777 1042
778This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 1043This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
779removed in future versions), and there is no public API to access override 1044removed in future versions), and there is no public API to access override
780results (if you must, access C<@cf::invoke_results> directly). 1045results (if you must, access C<@cf::INVOKE_RESULTS> directly).
781 1046
782=back 1047=back
783 1048
784=cut 1049=cut
785 1050
786############################################################################# 1051#############################################################################
787# object support 1052# object support
1053
1054sub _object_equal($$);
1055sub _object_equal($$) {
1056 my ($a, $b) = @_;
1057
1058 return 0 unless (ref $a) eq (ref $b);
1059
1060 if ("HASH" eq ref $a) {
1061 my @ka = keys %$a;
1062 my @kb = keys %$b;
1063
1064 return 0 if @ka != @kb;
1065
1066 for (0 .. $#ka) {
1067 return 0 unless $ka[$_] eq $kb[$_];
1068 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1069 }
1070
1071 } elsif ("ARRAY" eq ref $a) {
1072
1073 return 0 if @$a != @$b;
1074
1075 for (0 .. $#$a) {
1076 return 0 unless _object_equal $a->[$_], $b->[$_];
1077 }
1078
1079 } elsif ($a ne $b) {
1080 return 0;
1081 }
1082
1083 1
1084}
1085
1086our $SLOW_MERGES;#d#
1087sub _can_merge {
1088 my ($ob1, $ob2) = @_;
1089
1090 ++$SLOW_MERGES;#d#
1091
1092 # we do the slow way here
1093 return _object_equal $ob1, $ob2
1094}
788 1095
789sub reattach { 1096sub reattach {
790 # basically do the same as instantiate, without calling instantiate 1097 # basically do the same as instantiate, without calling instantiate
791 my ($obj) = @_; 1098 my ($obj) = @_;
1099
1100 # no longer needed after getting rid of delete_package?
1101 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
792 1102
793 my $registry = $obj->registry; 1103 my $registry = $obj->registry;
794 1104
795 @$registry = (); 1105 @$registry = ();
796 1106
811cf::attachable->attach ( 1121cf::attachable->attach (
812 prio => -1000000, 1122 prio => -1000000,
813 on_instantiate => sub { 1123 on_instantiate => sub {
814 my ($obj, $data) = @_; 1124 my ($obj, $data) = @_;
815 1125
816 $data = from_json $data; 1126 $data = decode_json $data;
817 1127
818 for (@$data) { 1128 for (@$data) {
819 my ($name, $args) = @$_; 1129 my ($name, $args) = @$_;
820 1130
821 $obj->attach ($name, %{$args || {} }); 1131 $obj->attach ($name, %{$args || {} });
837sub object_freezer_save { 1147sub object_freezer_save {
838 my ($filename, $rdata, $objs) = @_; 1148 my ($filename, $rdata, $objs) = @_;
839 1149
840 sync_job { 1150 sync_job {
841 if (length $$rdata) { 1151 if (length $$rdata) {
1152 utf8::decode (my $decname = $filename);
842 warn sprintf "saving %s (%d,%d)\n", 1153 warn sprintf "saving %s (%d,%d)\n",
843 $filename, length $$rdata, scalar @$objs; 1154 $decname, length $$rdata, scalar @$objs;
844 1155
845 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1156 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
846 chmod SAVE_MODE, $fh; 1157 aio_chmod $fh, SAVE_MODE;
847 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1158 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
848 aio_fsync $fh; 1159 aio_fsync $fh if $cf::USE_FSYNC;
849 close $fh; 1160 aio_close $fh;
850 1161
851 if (@$objs) { 1162 if (@$objs) {
852 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1163 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
853 chmod SAVE_MODE, $fh; 1164 aio_chmod $fh, SAVE_MODE;
854 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1165 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
855 aio_write $fh, 0, (length $data), $data, 0; 1166 aio_write $fh, 0, (length $data), $data, 0;
856 aio_fsync $fh; 1167 aio_fsync $fh if $cf::USE_FSYNC;
857 close $fh; 1168 aio_close $fh;
858 aio_rename "$filename.pst~", "$filename.pst"; 1169 aio_rename "$filename.pst~", "$filename.pst";
859 } 1170 }
860 } else { 1171 } else {
861 aio_unlink "$filename.pst"; 1172 aio_unlink "$filename.pst";
862 } 1173 }
867 } 1178 }
868 } else { 1179 } else {
869 aio_unlink $filename; 1180 aio_unlink $filename;
870 aio_unlink "$filename.pst"; 1181 aio_unlink "$filename.pst";
871 } 1182 }
872 } 1183 };
873} 1184}
874 1185
875sub object_freezer_as_string { 1186sub object_freezer_as_string {
876 my ($rdata, $objs) = @_; 1187 my ($rdata, $objs) = @_;
877 1188
889 or return; 1200 or return;
890 1201
891 unless (aio_stat "$filename.pst") { 1202 unless (aio_stat "$filename.pst") {
892 (aio_load "$filename.pst", $av) >= 0 1203 (aio_load "$filename.pst", $av) >= 0
893 or return; 1204 or return;
1205
894 $av = eval { (Storable::thaw $av)->{objs} }; 1206 my $st = eval { Coro::Storable::thaw $av };
1207 $av = $st->{objs};
895 } 1208 }
896 1209
1210 utf8::decode (my $decname = $filename);
897 warn sprintf "loading %s (%d)\n", 1211 warn sprintf "loading %s (%d,%d)\n",
898 $filename, length $data, scalar @{$av || []};#d# 1212 $decname, length $data, scalar @{$av || []};
1213
899 return ($data, $av); 1214 ($data, $av)
900} 1215}
1216
1217=head2 COMMAND CALLBACKS
1218
1219=over 4
1220
1221=cut
901 1222
902############################################################################# 1223#############################################################################
903# command handling &c 1224# command handling &c
904 1225
905=item cf::register_command $name => \&callback($ob,$args); 1226=item cf::register_command $name => \&callback($ob,$args);
918 push @{ $COMMAND{$name} }, [$caller, $cb]; 1239 push @{ $COMMAND{$name} }, [$caller, $cb];
919} 1240}
920 1241
921=item cf::register_extcmd $name => \&callback($pl,$packet); 1242=item cf::register_extcmd $name => \&callback($pl,$packet);
922 1243
923Register a callbackf ro execution when the client sends an extcmd packet. 1244Register a callback for execution when the client sends an (synchronous)
1245extcmd packet. Ext commands will be processed in the order they are
1246received by the server, like other user commands. The first argument is
1247the logged-in player. Ext commands can only be processed after a player
1248has logged in successfully.
924 1249
925If the callback returns something, it is sent back as if reply was being 1250If the callback returns something, it is sent back as if reply was being
926called. 1251called.
927 1252
1253=item cf::register_exticmd $name => \&callback($ns,$packet);
1254
1255Register a callback for execution when the client sends an (asynchronous)
1256exticmd packet. Exti commands are processed by the server as soon as they
1257are received, i.e. out of order w.r.t. other commands. The first argument
1258is a client socket. Exti commands can be received anytime, even before
1259log-in.
1260
1261If the callback returns something, it is sent back as if reply was being
1262called.
1263
928=cut 1264=cut
929 1265
930sub register_extcmd { 1266sub register_extcmd {
931 my ($name, $cb) = @_; 1267 my ($name, $cb) = @_;
932 1268
933 my $caller = caller;
934 #warn "registering extcmd '$name' to '$caller'";
935
936 $EXTCMD{$name} = [$cb, $caller]; 1269 $EXTCMD{$name} = $cb;
1270}
1271
1272sub register_exticmd {
1273 my ($name, $cb) = @_;
1274
1275 $EXTICMD{$name} = $cb;
937} 1276}
938 1277
939cf::player->attach ( 1278cf::player->attach (
940 on_command => sub { 1279 on_command => sub {
941 my ($pl, $name, $params) = @_; 1280 my ($pl, $name, $params) = @_;
950 cf::override; 1289 cf::override;
951 }, 1290 },
952 on_extcmd => sub { 1291 on_extcmd => sub {
953 my ($pl, $buf) = @_; 1292 my ($pl, $buf) = @_;
954 1293
955 my $msg = eval { from_json $buf }; 1294 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
956 1295
957 if (ref $msg) { 1296 if (ref $msg) {
1297 my ($type, $reply, @payload) =
1298 "ARRAY" eq ref $msg
1299 ? @$msg
1300 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1301
1302 my @reply;
1303
958 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1304 if (my $cb = $EXTCMD{$type}) {
959 if (my %reply = $cb->[0]->($pl, $msg)) { 1305 @reply = $cb->($pl, @payload);
960 $pl->ext_reply ($msg->{msgid}, %reply);
961 }
962 } 1306 }
1307
1308 $pl->ext_reply ($reply, @reply)
1309 if $reply;
1310
963 } else { 1311 } else {
964 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1312 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
965 } 1313 }
966 1314
967 cf::override; 1315 cf::override;
968 }, 1316 },
969); 1317);
970 1318
971sub register {
972 my ($base, $pkg) = @_;
973
974 #TODO
975}
976
977sub load_extension { 1319sub load_extensions {
1320 cf::sync_job {
1321 my %todo;
1322
1323 for my $path (<$LIBDIR/*.ext>) {
1324 next unless -r $path;
1325
1326 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1327 my $base = $1;
1328 my $pkg = $1;
1329 $pkg =~ s/[^[:word:]]/_/g;
1330 $pkg = "ext::$pkg";
1331
1332 open my $fh, "<:utf8", $path
1333 or die "$path: $!";
1334
1335 my $source = do { local $/; <$fh> };
1336
1337 my %ext = (
1338 path => $path,
1339 base => $base,
1340 pkg => $pkg,
1341 );
1342
1343 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1344 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1345
1346 $ext{source} =
1347 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1348 . "#line 1 \"$path\"\n{\n"
1349 . $source
1350 . "\n};\n1";
1351
1352 $todo{$base} = \%ext;
1353 }
1354
1355 my %done;
1356 while (%todo) {
1357 my $progress;
1358
1359 while (my ($k, $v) = each %todo) {
1360 for (split /,\s*/, $v->{meta}{depends}) {
1361 goto skip
1362 unless exists $done{$_};
1363 }
1364
1365 warn "... loading '$k' into '$v->{pkg}'\n";
1366
1367 unless (eval $v->{source}) {
1368 my $msg = $@ ? "$v->{path}: $@\n"
1369 : "$v->{base}: extension inactive.\n";
1370
1371 if (exists $v->{meta}{mandatory}) {
1372 warn $msg;
1373 cf::cleanup "mandatory extension failed to load, exiting.";
1374 }
1375
1376 warn $msg;
1377 }
1378
1379 $done{$k} = delete $todo{$k};
1380 push @EXTS, $v->{pkg};
1381 $progress = 1;
1382 }
1383
1384 skip:
1385 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1386 unless $progress;
1387 }
1388 };
1389}
1390
1391#############################################################################
1392
1393=back
1394
1395=head2 CORE EXTENSIONS
1396
1397Functions and methods that extend core deliantra objects.
1398
1399=cut
1400
1401package cf::player;
1402
1403use Coro::AIO;
1404
1405=head3 cf::player
1406
1407=over 4
1408
1409=item cf::player::num_playing
1410
1411Returns the official number of playing players, as per the Crossfire metaserver rules.
1412
1413=cut
1414
1415sub num_playing {
1416 scalar grep
1417 $_->ob->map
1418 && !$_->hidden
1419 && !$_->ob->flag (cf::FLAG_WIZ),
1420 cf::player::list
1421}
1422
1423=item cf::player::find $login
1424
1425Returns the given player object, loading it if necessary (might block).
1426
1427=cut
1428
1429sub playerdir($) {
1430 "$PLAYERDIR/"
1431 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1432}
1433
1434sub path($) {
1435 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1436
1437 (playerdir $login) . "/playerdata"
1438}
1439
1440sub find_active($) {
1441 $cf::PLAYER{$_[0]}
1442 and $cf::PLAYER{$_[0]}->active
1443 and $cf::PLAYER{$_[0]}
1444}
1445
1446sub exists($) {
1447 my ($login) = @_;
1448
1449 $cf::PLAYER{$login}
1450 or !aio_stat path $login
1451}
1452
1453sub find($) {
1454 return $cf::PLAYER{$_[0]} || do {
1455 my $login = $_[0];
1456
1457 my $guard = cf::lock_acquire "user_find:$login";
1458
1459 $cf::PLAYER{$_[0]} || do {
1460 # rename old playerfiles to new ones
1461 #TODO: remove when no longer required
1462 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1463 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1464 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1465 aio_unlink +(playerdir $login) . "/$login.pl";
1466
1467 my $f = new_from_file cf::object::thawer path $login
1468 or return;
1469
1470 my $pl = cf::player::load_pl $f
1471 or return;
1472
1473 local $cf::PLAYER_LOADING{$login} = $pl;
1474 $f->resolve_delayed_derefs;
1475 $cf::PLAYER{$login} = $pl
1476 }
1477 }
1478}
1479
1480sub save($) {
1481 my ($pl) = @_;
1482
1483 return if $pl->{deny_save};
1484
1485 my $path = path $pl;
1486 my $guard = cf::lock_acquire "user_save:$path";
1487
1488 return if $pl->{deny_save};
1489
1490 aio_mkdir playerdir $pl, 0770;
1491 $pl->{last_save} = $cf::RUNTIME;
1492
1493 cf::get_slot 0.01;
1494
1495 $pl->save_pl ($path);
1496 cf::cede_to_tick;
1497}
1498
1499sub new($) {
1500 my ($login) = @_;
1501
1502 my $self = create;
1503
1504 $self->ob->name ($login);
1505 $self->{deny_save} = 1;
1506
1507 $cf::PLAYER{$login} = $self;
1508
1509 $self
1510}
1511
1512=item $player->send_msg ($channel, $msg, $color, [extra...])
1513
1514=cut
1515
1516sub send_msg {
1517 my $ns = shift->ns
1518 or return;
1519 $ns->send_msg (@_);
1520}
1521
1522=item $pl->quit_character
1523
1524Nukes the player without looking back. If logged in, the connection will
1525be destroyed. May block for a long time.
1526
1527=cut
1528
1529sub quit_character {
1530 my ($pl) = @_;
1531
1532 my $name = $pl->ob->name;
1533
1534 $pl->{deny_save} = 1;
1535 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1536
1537 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1538 $pl->deactivate;
1539 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1540 $pl->ob->check_score;
1541 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1542 $pl->ns->destroy if $pl->ns;
1543
1544 my $path = playerdir $pl;
1545 my $temp = "$path~$cf::RUNTIME~deleting~";
1546 aio_rename $path, $temp;
1547 delete $cf::PLAYER{$pl->ob->name};
1548 $pl->destroy;
1549
1550 my $prefix = qr<^~\Q$name\E/>;
1551
1552 # nuke player maps
1553 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1554
1555 IO::AIO::aio_rmtree $temp;
1556}
1557
1558=item $pl->kick
1559
1560Kicks a player out of the game. This destroys the connection.
1561
1562=cut
1563
1564sub kick {
1565 my ($pl, $kicker) = @_;
1566
1567 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1568 $pl->killer ("kicked");
1569 $pl->ns->destroy;
1570}
1571
1572=item cf::player::list_logins
1573
1574Returns am arrayref of all valid playernames in the system, can take a
1575while and may block, so not sync_job-capable, ever.
1576
1577=cut
1578
1579sub list_logins {
1580 my $dirs = aio_readdir $PLAYERDIR
1581 or return [];
1582
1583 my @logins;
1584
1585 for my $login (@$dirs) {
1586 my $path = path $login;
1587
1588 # a .pst is a dead give-away for a valid player
1589 # if no pst file found, open and chekc for blocked users
1590 if (aio_stat "$path.pst") {
1591 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1592 aio_read $fh, 0, 512, my $buf, 0 or next;
1593 $buf !~ /^password -------------$/m or next; # official not-valid tag
1594 }
1595
1596 utf8::decode $login;
1597 push @logins, $login;
1598 }
1599
1600 \@logins
1601}
1602
1603=item $player->maps
1604
1605Returns an arrayref of map paths that are private for this
1606player. May block.
1607
1608=cut
1609
1610sub maps($) {
1611 my ($pl) = @_;
1612
1613 $pl = ref $pl ? $pl->ob->name : $pl;
1614
1615 my $files = aio_readdir playerdir $pl
1616 or return;
1617
1618 my @paths;
1619
1620 for (@$files) {
1621 utf8::decode $_;
1622 next if /\.(?:pl|pst)$/;
1623 next unless /^$PATH_SEP/o;
1624
1625 push @paths, cf::map::normalise "~$pl/$_";
1626 }
1627
1628 \@paths
1629}
1630
1631=item $protocol_xml = $player->expand_cfpod ($cfpod)
1632
1633Expand deliantra pod fragments into protocol xml.
1634
1635=item $player->ext_reply ($msgid, @msg)
1636
1637Sends an ext reply to the player.
1638
1639=cut
1640
1641sub ext_reply($$@) {
1642 my ($self, $id, @msg) = @_;
1643
1644 $self->ns->ext_reply ($id, @msg)
1645}
1646
1647=item $player->ext_msg ($type, @msg)
1648
1649Sends an ext event to the client.
1650
1651=cut
1652
1653sub ext_msg($$@) {
1654 my ($self, $type, @msg) = @_;
1655
1656 $self->ns->ext_msg ($type, @msg);
1657}
1658
1659=head3 cf::region
1660
1661=over 4
1662
1663=cut
1664
1665package cf::region;
1666
1667=item cf::region::find_by_path $path
1668
1669Tries to decuce the likely region for a map knowing only its path.
1670
1671=cut
1672
1673sub find_by_path($) {
978 my ($path) = @_; 1674 my ($path) = @_;
979 1675
980 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1676 my ($match, $specificity);
981 my $base = $1;
982 my $pkg = $1;
983 $pkg =~ s/[^[:word:]]/_/g;
984 $pkg = "ext::$pkg";
985 1677
986 warn "loading '$path' into '$pkg'\n"; 1678 for my $region (list) {
987 1679 if ($region->{match} && $path =~ $region->{match}) {
988 open my $fh, "<:utf8", $path 1680 ($match, $specificity) = ($region, $region->specificity)
989 or die "$path: $!"; 1681 if $region->specificity > $specificity;
990 1682 }
991 my $source =
992 "package $pkg; use strict; use utf8;\n"
993 . "#line 1 \"$path\"\n{\n"
994 . (do { local $/; <$fh> })
995 . "\n};\n1";
996
997 eval $source
998 or die $@ ? "$path: $@\n"
999 : "extension disabled.\n";
1000
1001 push @exts, $pkg;
1002 $ext_pkg{$base} = $pkg;
1003
1004# no strict 'refs';
1005# @{"$pkg\::ISA"} = ext::;
1006
1007 register $base, $pkg;
1008}
1009
1010sub unload_extension {
1011 my ($pkg) = @_;
1012
1013 warn "removing extension $pkg\n";
1014
1015 # remove hooks
1016 #TODO
1017# for my $idx (0 .. $#PLUGIN_EVENT) {
1018# delete $hook[$idx]{$pkg};
1019# } 1683 }
1020 1684
1021 # remove commands 1685 $match
1022 for my $name (keys %COMMAND) {
1023 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1024
1025 if (@cb) {
1026 $COMMAND{$name} = \@cb;
1027 } else {
1028 delete $COMMAND{$name};
1029 }
1030 }
1031
1032 # remove extcmds
1033 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1034 delete $EXTCMD{$name};
1035 }
1036
1037 if (my $cb = $pkg->can ("unload")) {
1038 eval {
1039 $cb->($pkg);
1040 1
1041 } or warn "$pkg unloaded, but with errors: $@";
1042 }
1043
1044 Symbol::delete_package $pkg;
1045}
1046
1047sub load_extensions {
1048 for my $ext (<$LIBDIR/*.ext>) {
1049 next unless -r $ext;
1050 eval {
1051 load_extension $ext;
1052 1
1053 } or warn "$ext not loaded: $@";
1054 }
1055}
1056
1057#############################################################################
1058# load/save/clean perl data associated with a map
1059
1060*cf::mapsupport::on_clean = sub {
1061 my ($map) = @_;
1062
1063 my $path = $map->tmpname;
1064 defined $path or return;
1065
1066 unlink "$path.pst";
1067};
1068
1069cf::map->attach (prio => -10000, package => cf::mapsupport::);
1070
1071#############################################################################
1072# load/save perl data associated with player->ob objects
1073
1074sub all_objects(@) {
1075 @_, map all_objects ($_->inv), @_
1076}
1077
1078# TODO: compatibility cruft, remove when no longer needed
1079cf::player->attach (
1080 on_load => sub {
1081 my ($pl, $path) = @_;
1082
1083 for my $o (all_objects $pl->ob) {
1084 if (my $value = $o->get_ob_key_value ("_perl_data")) {
1085 $o->set_ob_key_value ("_perl_data");
1086
1087 %$o = %{ Storable::thaw pack "H*", $value };
1088 }
1089 }
1090 },
1091);
1092
1093#############################################################################
1094
1095=head2 CORE EXTENSIONS
1096
1097Functions and methods that extend core crossfire objects.
1098
1099=head3 cf::player
1100
1101=over 4
1102
1103=item cf::player::exists $login
1104
1105Returns true when the given account exists.
1106
1107=cut
1108
1109sub cf::player::exists($) {
1110 cf::player::find $_[0]
1111 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
1112}
1113
1114=item $player->ext_reply ($msgid, $msgtype, %msg)
1115
1116Sends an ext reply to the player.
1117
1118=cut
1119
1120sub cf::player::ext_reply($$$%) {
1121 my ($self, $id, %msg) = @_;
1122
1123 $msg{msgid} = $id;
1124
1125 $self->send ("ext " . to_json \%msg);
1126} 1686}
1127 1687
1128=back 1688=back
1129
1130 1689
1131=head3 cf::map 1690=head3 cf::map
1132 1691
1133=over 4 1692=over 4
1134 1693
1137package cf::map; 1696package cf::map;
1138 1697
1139use Fcntl; 1698use Fcntl;
1140use Coro::AIO; 1699use Coro::AIO;
1141 1700
1701use overload
1702 '""' => \&as_string,
1703 fallback => 1;
1704
1142our $MAX_RESET = 7200; 1705our $MAX_RESET = 3600;
1143our $DEFAULT_RESET = 3600; 1706our $DEFAULT_RESET = 3000;
1144 1707
1145sub generate_random_map { 1708sub generate_random_map {
1146 my ($path, $rmp) = @_; 1709 my ($self, $rmp) = @_;
1710
1711 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1147 1712
1148 # mit "rum" bekleckern, nicht 1713 # mit "rum" bekleckern, nicht
1149 cf::map::_create_random_map 1714 $self->_create_random_map (
1150 $path,
1151 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1715 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1152 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1716 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1153 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1717 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1154 $rmp->{exit_on_final_map}, 1718 $rmp->{exit_on_final_map},
1155 $rmp->{xsize}, $rmp->{ysize}, 1719 $rmp->{xsize}, $rmp->{ysize},
1156 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1720 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1157 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1721 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1158 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1722 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1159 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp}, 1723 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1160 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1724 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1161 (cf::region::find $rmp->{region}) 1725 (cf::region::find $rmp->{region}), $rmp->{custom}
1726 )
1727}
1728
1729=item cf::map->register ($regex, $prio)
1730
1731Register a handler for the map path matching the given regex at the
1732givne priority (higher is better, built-in handlers have priority 0, the
1733default).
1734
1735=cut
1736
1737sub register {
1738 my (undef, $regex, $prio) = @_;
1739 my $pkg = caller;
1740
1741 no strict;
1742 push @{"$pkg\::ISA"}, __PACKAGE__;
1743
1744 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1745}
1746
1747# also paths starting with '/'
1748$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1749
1750sub thawer_merge {
1751 my ($self, $merge) = @_;
1752
1753 # we have to keep some variables in memory intact
1754 local $self->{path};
1755 local $self->{load_path};
1756
1757 $self->SUPER::thawer_merge ($merge);
1758}
1759
1760sub normalise {
1761 my ($path, $base) = @_;
1762
1763 $path = "$path"; # make sure its a string
1764
1765 $path =~ s/\.map$//;
1766
1767 # map plan:
1768 #
1769 # /! non-realised random map exit (special hack!)
1770 # {... are special paths that are not being touched
1771 # ?xxx/... are special absolute paths
1772 # ?random/... random maps
1773 # /... normal maps
1774 # ~user/... per-player map of a specific user
1775
1776 $path =~ s/$PATH_SEP/\//go;
1777
1778 # treat it as relative path if it starts with
1779 # something that looks reasonable
1780 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1781 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1782
1783 $base =~ s{[^/]+/?$}{};
1784 $path = "$base/$path";
1785 }
1786
1787 for ($path) {
1788 redo if s{//}{/};
1789 redo if s{/\.?/}{/};
1790 redo if s{/[^/]+/\.\./}{/};
1791 }
1792
1793 $path
1794}
1795
1796sub new_from_path {
1797 my (undef, $path, $base) = @_;
1798
1799 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1800
1801 $path = normalise $path, $base;
1802
1803 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1804 if ($path =~ $EXT_MAP{$pkg}[1]) {
1805 my $self = bless cf::map::new, $pkg;
1806 $self->{path} = $path; $self->path ($path);
1807 $self->init; # pass $1 etc.
1808 return $self;
1809 }
1810 }
1811
1812 Carp::cluck "unable to resolve path '$path' (base '$base').";
1813 ()
1814}
1815
1816sub init {
1817 my ($self) = @_;
1818
1819 $self
1820}
1821
1822sub as_string {
1823 my ($self) = @_;
1824
1825 "$self->{path}"
1826}
1827
1828# the displayed name, this is a one way mapping
1829sub visible_name {
1830 &as_string
1831}
1832
1833# the original (read-only) location
1834sub load_path {
1835 my ($self) = @_;
1836
1837 "$MAPDIR/$self->{path}.map"
1838}
1839
1840# the temporary/swap location
1841sub save_path {
1842 my ($self) = @_;
1843
1844 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1845 "$TMPDIR/$path.map"
1846}
1847
1848# the unique path, undef == no special unique path
1849sub uniq_path {
1850 my ($self) = @_;
1851
1852 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1853 "$UNIQUEDIR/$path"
1162} 1854}
1163 1855
1164# and all this just because we cannot iterate over 1856# and all this just because we cannot iterate over
1165# all maps in C++... 1857# all maps in C++...
1166sub change_all_map_light { 1858sub change_all_map_light {
1168 1860
1169 $_->change_map_light ($change) 1861 $_->change_map_light ($change)
1170 for grep $_->outdoor, values %cf::MAP; 1862 for grep $_->outdoor, values %cf::MAP;
1171} 1863}
1172 1864
1865sub decay_objects {
1866 my ($self) = @_;
1867
1868 return if $self->{deny_reset};
1869
1870 $self->do_decay_objects;
1871}
1872
1873sub unlink_save {
1874 my ($self) = @_;
1875
1876 utf8::encode (my $save = $self->save_path);
1877 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1878 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1879}
1880
1173sub try_load_header($) { 1881sub load_header_from($) {
1174 my ($path) = @_; 1882 my ($self, $path) = @_;
1175 1883
1176 utf8::encode $path; 1884 utf8::encode $path;
1177 aio_open $path, O_RDONLY, 0 1885 my $f = new_from_file cf::object::thawer $path
1178 or return; 1886 or return;
1179 1887
1180 my $map = cf::map::new 1888 $self->_load_header ($f)
1181 or return; 1889 or return;
1182 1890
1183 $map->load_header ($path) 1891 local $MAP_LOADING{$self->{path}} = $self;
1892 $f->resolve_delayed_derefs;
1893
1894 $self->{load_path} = $path;
1895
1896 1
1897}
1898
1899sub load_header_orig {
1900 my ($self) = @_;
1901
1902 $self->load_header_from ($self->load_path)
1903}
1904
1905sub load_header_temp {
1906 my ($self) = @_;
1907
1908 $self->load_header_from ($self->save_path)
1909}
1910
1911sub prepare_temp {
1912 my ($self) = @_;
1913
1914 $self->last_access ((delete $self->{last_access})
1915 || $cf::RUNTIME); #d#
1916 # safety
1917 $self->{instantiate_time} = $cf::RUNTIME
1918 if $self->{instantiate_time} > $cf::RUNTIME;
1919}
1920
1921sub prepare_orig {
1922 my ($self) = @_;
1923
1924 $self->{load_original} = 1;
1925 $self->{instantiate_time} = $cf::RUNTIME;
1926 $self->last_access ($cf::RUNTIME);
1927 $self->instantiate;
1928}
1929
1930sub load_header {
1931 my ($self) = @_;
1932
1933 if ($self->load_header_temp) {
1934 $self->prepare_temp;
1935 } else {
1936 $self->load_header_orig
1184 or return; 1937 or return;
1938 $self->prepare_orig;
1939 }
1185 1940
1186 $map->{load_path} = $path; 1941 $self->{deny_reset} = 1
1942 if $self->no_reset;
1187 1943
1188 $map 1944 $self->default_region (cf::region::find_by_path $self->{path})
1189} 1945 unless $self->default_region;
1190 1946
1947 1
1948}
1949
1191sub find_map; 1950sub find;
1192sub find_map { 1951sub find {
1193 my ($path, $origin) = @_; 1952 my ($path, $origin) = @_;
1194 1953
1195 #warn "find_map<$path,$origin>\n";#d#
1196
1197 $path = new cf::path $path, $origin && $origin->path; 1954 $path = normalise $path, $origin && $origin->path;
1198 my $key = $path->as_string;
1199 1955
1956 cf::lock_wait "map_data:$path";#d#remove
1200 cf::lock_wait "map_find:$key"; 1957 cf::lock_wait "map_find:$path";
1201 1958
1202 $cf::MAP{$key} || do { 1959 $cf::MAP{$path} || do {
1960 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1203 my $guard = cf::lock_acquire "map_find:$key"; 1961 my $guard2 = cf::lock_acquire "map_find:$path";
1204 1962
1205 # do it the slow way 1963 my $map = new_from_path cf::map $path
1206 my $map = try_load_header $path->save_path;
1207
1208 if ($map) {
1209 # safety
1210 $map->{instantiate_time} = $cf::RUNTIME
1211 if $map->{instantiate_time} > $cf::RUNTIME;
1212 } else {
1213 if (my $rmp = $path->random_map_params) {
1214 $map = generate_random_map $key, $rmp;
1215 } else {
1216 $map = try_load_header $path->load_path;
1217 }
1218
1219 $map or return; 1964 or return;
1220 1965
1221 $map->{load_original} = 1;
1222 $map->{instantiate_time} = $cf::RUNTIME;
1223 $map->instantiate;
1224
1225 # per-player maps become, after loading, normal maps
1226 $map->per_player (0) if $path->{user_rel};
1227 }
1228
1229 $map->path ($key);
1230 $map->{path} = $path;
1231 $map->{last_save} = $cf::RUNTIME; 1966 $map->{last_save} = $cf::RUNTIME;
1232 $map->last_access ($cf::RUNTIME);
1233 1967
1234 if ($map->should_reset) { 1968 $map->load_header
1969 or return;
1970
1971 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1972 # doing this can freeze the server in a sync job, obviously
1973 #$cf::WAIT_FOR_TICK->wait;
1974 undef $guard2;
1975 undef $guard1;
1235 $map->reset; 1976 $map->reset;
1236 undef $guard; 1977 return find $path;
1237 $map = find_map $path
1238 or return;
1239 } 1978 }
1240 1979
1241 $cf::MAP{$key} = $map 1980 $cf::MAP{$path} = $map
1242 } 1981 }
1243} 1982}
1983
1984sub pre_load { }
1985sub post_load { }
1244 1986
1245sub load { 1987sub load {
1246 my ($self) = @_; 1988 my ($self) = @_;
1247 1989
1990 local $self->{deny_reset} = 1; # loading can take a long time
1991
1248 my $path = $self->{path}; 1992 my $path = $self->{path};
1993
1994 {
1249 my $guard = cf::lock_acquire "map_load:" . $path->as_string; 1995 my $guard = cf::lock_acquire "map_data:$path";
1250 1996
1997 return unless $self->valid;
1251 return if $self->in_memory != cf::MAP_SWAPPED; 1998 return unless $self->in_memory == cf::MAP_SWAPPED;
1252 1999
1253 $self->in_memory (cf::MAP_LOADING); 2000 $self->in_memory (cf::MAP_LOADING);
1254 2001
1255 $self->alloc; 2002 $self->alloc;
1256 $self->load_objects ($self->{load_path}, 1) 2003
2004 $self->pre_load;
2005 cf::cede_to_tick;
2006
2007 my $f = new_from_file cf::object::thawer $self->{load_path};
2008 $f->skip_block;
2009 $self->_load_objects ($f)
1257 or return; 2010 or return;
1258 2011
1259 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2012 $self->post_load_original
1260 if delete $self->{load_original}; 2013 if delete $self->{load_original};
1261 2014
1262 if (my $uniq = $path->uniq_path) { 2015 if (my $uniq = $self->uniq_path) {
1263 utf8::encode $uniq; 2016 utf8::encode $uniq;
1264 if (aio_open $uniq, O_RDONLY, 0) { 2017 unless (aio_stat $uniq) {
2018 if (my $f = new_from_file cf::object::thawer $uniq) {
1265 $self->clear_unique_items; 2019 $self->clear_unique_items;
1266 $self->load_objects ($uniq, 0); 2020 $self->_load_objects ($f);
2021 $f->resolve_delayed_derefs;
2022 }
1267 } 2023 }
1268 } 2024 }
1269 2025
2026 $f->resolve_delayed_derefs;
2027
2028 cf::cede_to_tick;
1270 # now do the right thing for maps 2029 # now do the right thing for maps
1271 $self->link_multipart_objects; 2030 $self->link_multipart_objects;
1272
1273 if ($self->{path}->is_style_map) {
1274 $self->{deny_save} = 1;
1275 $self->{deny_reset} = 1;
1276 } else {
1277 $self->fix_auto_apply;
1278 $self->decay_objects;
1279 $self->update_buttons;
1280 $self->set_darkness_map;
1281 $self->difficulty ($self->estimate_difficulty) 2031 $self->difficulty ($self->estimate_difficulty)
1282 unless $self->difficulty; 2032 unless $self->difficulty;
2033 cf::cede_to_tick;
2034
2035 unless ($self->{deny_activate}) {
2036 $self->decay_objects;
2037 $self->fix_auto_apply;
2038 $self->update_buttons;
2039 cf::cede_to_tick;
2040 $self->set_darkness_map;
2041 cf::cede_to_tick;
1283 $self->activate; 2042 $self->activate;
1284 } 2043 }
1285 2044
2045 $self->{last_save} = $cf::RUNTIME;
2046 $self->last_access ($cf::RUNTIME);
2047
1286 $self->in_memory (cf::MAP_IN_MEMORY); 2048 $self->in_memory (cf::MAP_ACTIVE);
1287} 2049 }
1288 2050
1289sub load_map_sync { 2051 $self->post_load;
2052}
2053
2054sub customise_for {
2055 my ($self, $ob) = @_;
2056
2057 return find "~" . $ob->name . "/" . $self->{path}
2058 if $self->per_player;
2059
2060# return find "?party/" . $ob->name . "/" . $self->{path}
2061# if $self->per_party;
2062
2063 $self
2064}
2065
2066# find and load all maps in the 3x3 area around a map
2067sub load_neighbours {
2068 my ($map) = @_;
2069
2070 my @neigh; # diagonal neighbours
2071
2072 for (0 .. 3) {
2073 my $neigh = $map->tile_path ($_)
2074 or next;
2075 $neigh = find $neigh, $map
2076 or next;
2077 $neigh->load;
2078
2079 push @neigh,
2080 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2081 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2082 }
2083
2084 for (grep defined $_->[0], @neigh) {
2085 my ($path, $origin) = @$_;
2086 my $neigh = find $path, $origin
2087 or next;
2088 $neigh->load;
2089 }
2090}
2091
2092sub find_sync {
1290 my ($path, $origin) = @_; 2093 my ($path, $origin) = @_;
1291 2094
1292 #warn "load_map_sync<$path, $origin>\n";#d# 2095 cf::sync_job { find $path, $origin }
2096}
1293 2097
1294 cf::sync_job { 2098sub do_load_sync {
1295 my $map = cf::map::find_map $path, $origin 2099 my ($map) = @_;
1296 or return; 2100
1297 $map->load; 2101 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
1298 $map 2102 if $Coro::current == $Coro::main;
2103
2104 cf::sync_job { $map->load };
2105}
2106
2107our %MAP_PREFETCH;
2108our $MAP_PREFETCHER = undef;
2109
2110sub find_async {
2111 my ($path, $origin, $load) = @_;
2112
2113 $path = normalise $path, $origin && $origin->{path};
2114
2115 if (my $map = $cf::MAP{$path}) {
2116 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2117 }
2118
2119 $MAP_PREFETCH{$path} |= $load;
2120
2121 $MAP_PREFETCHER ||= cf::async {
2122 $Coro::current->{desc} = "map prefetcher";
2123
2124 while (%MAP_PREFETCH) {
2125 while (my ($k, $v) = each %MAP_PREFETCH) {
2126 if (my $map = find $k) {
2127 $map->load if $v;
2128 }
2129
2130 delete $MAP_PREFETCH{$k};
2131 }
2132 }
2133 undef $MAP_PREFETCHER;
1299 } 2134 };
2135 $MAP_PREFETCHER->prio (6);
2136
2137 ()
1300} 2138}
1301 2139
1302sub save { 2140sub save {
1303 my ($self) = @_; 2141 my ($self) = @_;
1304 2142
2143 my $lock = cf::lock_acquire "map_data:$self->{path}";
2144
1305 $self->{last_save} = $cf::RUNTIME; 2145 $self->{last_save} = $cf::RUNTIME;
1306 2146
1307 return unless $self->dirty; 2147 return unless $self->dirty;
1308 2148
1309 my $save = $self->{path}->save_path; utf8::encode $save; 2149 my $save = $self->save_path; utf8::encode $save;
1310 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 2150 my $uniq = $self->uniq_path; utf8::encode $uniq;
1311 2151
1312 $self->{load_path} = $save; 2152 $self->{load_path} = $save;
1313 2153
1314 return if $self->{deny_save}; 2154 return if $self->{deny_save};
1315 2155
2156 local $self->{last_access} = $self->last_access;#d#
2157
2158 cf::async {
2159 $Coro::current->{desc} = "map player save";
2160 $_->contr->save for $self->players;
2161 };
2162
2163 cf::get_slot 0.02;
2164
1316 if ($uniq) { 2165 if ($uniq) {
1317 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2166 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1318 $self->save_objects ($uniq, cf::IO_UNIQUES); 2167 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1319 } else { 2168 } else {
1320 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2169 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1321 } 2170 }
1322} 2171}
1323 2172
1324sub swap_out { 2173sub swap_out {
1325 my ($self) = @_; 2174 my ($self) = @_;
1326 2175
2176 # save first because save cedes
2177 $self->save;
2178
2179 my $lock = cf::lock_acquire "map_data:$self->{path}";
2180
1327 return if $self->players; 2181 return if $self->players;
1328 return if $self->in_memory != cf::MAP_IN_MEMORY; 2182 return if $self->in_memory != cf::MAP_ACTIVE;
1329 return if $self->{deny_save}; 2183 return if $self->{deny_save};
1330 2184
2185 $self->in_memory (cf::MAP_SWAPPED);
2186
1331 $self->save; 2187 $self->deactivate;
2188 $_->clear_links_to ($self) for values %cf::MAP;
1332 $self->clear; 2189 $self->clear;
1333 $self->in_memory (cf::MAP_SWAPPED);
1334} 2190}
1335 2191
1336sub reset_at { 2192sub reset_at {
1337 my ($self) = @_; 2193 my ($self) = @_;
1338 2194
1339 # TODO: safety, remove and allow resettable per-player maps 2195 # TODO: safety, remove and allow resettable per-player maps
1340 return 1e99 if $self->{path}{user_rel};
1341 return 1e99 if $self->{deny_reset}; 2196 return 1e99 if $self->{deny_reset};
1342 2197
1343 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2198 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1344 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2199 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1345 2200
1350 my ($self) = @_; 2205 my ($self) = @_;
1351 2206
1352 $self->reset_at <= $cf::RUNTIME 2207 $self->reset_at <= $cf::RUNTIME
1353} 2208}
1354 2209
1355sub unlink_save {
1356 my ($self) = @_;
1357
1358 utf8::encode (my $save = $self->{path}->save_path);
1359 aioreq_pri 3; IO::AIO::aio_unlink $save;
1360 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1361}
1362
1363sub rename {
1364 my ($self, $new_path) = @_;
1365
1366 $self->unlink_save;
1367
1368 delete $cf::MAP{$self->path};
1369 $self->{path} = new cf::path $new_path;
1370 $self->path ($self->{path}->as_string);
1371 $cf::MAP{$self->path} = $self;
1372
1373 $self->save;
1374}
1375
1376sub reset { 2210sub reset {
1377 my ($self) = @_; 2211 my ($self) = @_;
1378 2212
2213 my $lock = cf::lock_acquire "map_data:$self->{path}";
2214
1379 return if $self->players; 2215 return if $self->players;
1380 return if $self->{path}{user_rel};#d#
1381 2216
1382 warn "resetting map ", $self->path;#d# 2217 warn "resetting map ", $self->path;
2218
2219 $self->in_memory (cf::MAP_SWAPPED);
2220
2221 # need to save uniques path
2222 unless ($self->{deny_save}) {
2223 my $uniq = $self->uniq_path; utf8::encode $uniq;
2224
2225 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2226 if $uniq;
2227 }
1383 2228
1384 delete $cf::MAP{$self->path}; 2229 delete $cf::MAP{$self->path};
1385 2230
2231 $self->deactivate;
1386 $_->clear_links_to ($self) for values %cf::MAP; 2232 $_->clear_links_to ($self) for values %cf::MAP;
2233 $self->clear;
1387 2234
1388 $self->unlink_save; 2235 $self->unlink_save;
1389 $self->destroy; 2236 $self->destroy;
1390} 2237}
1391 2238
1392my $nuke_counter = "aaaa"; 2239my $nuke_counter = "aaaa";
1393 2240
1394sub nuke { 2241sub nuke {
1395 my ($self) = @_; 2242 my ($self) = @_;
1396 2243
2244 {
2245 my $lock = cf::lock_acquire "map_data:$self->{path}";
2246
2247 delete $cf::MAP{$self->path};
2248
2249 $self->unlink_save;
2250
2251 bless $self, "cf::map";
2252 delete $self->{deny_reset};
1397 $self->{deny_save} = 1; 2253 $self->{deny_save} = 1;
1398 $self->reset_timeout (1); 2254 $self->reset_timeout (1);
1399 $self->rename ("{nuke}/" . ($nuke_counter++)); 2255 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2256
2257 $cf::MAP{$self->path} = $self;
2258 }
2259
1400 $self->reset; # polite request, might not happen 2260 $self->reset; # polite request, might not happen
1401} 2261}
1402 2262
1403sub customise_for { 2263=item $maps = cf::map::tmp_maps
1404 my ($map, $ob) = @_;
1405 2264
1406 if ($map->per_player) { 2265Returns an arrayref with all map paths of currently instantiated and saved
1407 return cf::map::find_map "~" . $ob->name . "/" . $map->{path}{path}; 2266maps. May block.
2267
2268=cut
2269
2270sub tmp_maps() {
1408 } 2271 [
1409 2272 map {
1410 $map 2273 utf8::decode $_;
2274 /\.map$/
2275 ? normalise $_
2276 : ()
2277 } @{ aio_readdir $TMPDIR or [] }
2278 ]
1411} 2279}
1412 2280
1413sub emergency_save { 2281=item $maps = cf::map::random_maps
1414 local $cf::FREEZE = 1;
1415 2282
1416 warn "enter emergency map save\n"; 2283Returns an arrayref with all map paths of currently instantiated and saved
2284random maps. May block.
1417 2285
1418 cf::sync_job { 2286=cut
1419 warn "begin emergency map save\n"; 2287
1420 $_->save for values %cf::MAP; 2288sub random_maps() {
2289 [
2290 map {
2291 utf8::decode $_;
2292 /\.map$/
2293 ? normalise "?random/$_"
2294 : ()
2295 } @{ aio_readdir $RANDOMDIR or [] }
2296 ]
2297}
2298
2299=item cf::map::unique_maps
2300
2301Returns an arrayref of paths of all shared maps that have
2302instantiated unique items. May block.
2303
2304=cut
2305
2306sub unique_maps() {
2307 [
2308 map {
2309 utf8::decode $_;
2310 s/\.map$//; # TODO future compatibility hack
2311 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2312 ? ()
2313 : normalise $_
2314 } @{ aio_readdir $UNIQUEDIR or [] }
2315 ]
2316}
2317
2318=back
2319
2320=head3 cf::object
2321
2322=cut
2323
2324package cf::object;
2325
2326=over 4
2327
2328=item $ob->inv_recursive
2329
2330Returns the inventory of the object I<and> their inventories, recursively,
2331but I<not> the object itself.
2332
2333=cut
2334
2335sub inv_recursive_;
2336sub inv_recursive_ {
2337 map { $_, inv_recursive_ $_->inv } @_
2338}
2339
2340sub inv_recursive {
2341 inv_recursive_ inv $_[0]
2342}
2343
2344=item $ref = $ob->ref
2345
2346Creates and returns a persistent reference to an object that can be stored as a string.
2347
2348=item $ob = cf::object::deref ($refstring)
2349
2350returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2351even if the object actually exists. May block.
2352
2353=cut
2354
2355sub deref {
2356 my ($ref) = @_;
2357
2358 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2359 my ($uuid, $name) = ($1, $2);
2360 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2361 or return;
2362 $pl->ob->uuid eq $uuid
2363 or return;
2364
2365 $pl->ob
2366 } else {
2367 warn "$ref: cannot resolve object reference\n";
2368 undef
1421 }; 2369 }
1422
1423 warn "end emergency map save\n";
1424} 2370}
1425 2371
1426package cf; 2372package cf;
1427 2373
1428=back 2374=back
1429
1430 2375
1431=head3 cf::object::player 2376=head3 cf::object::player
1432 2377
1433=over 4 2378=over 4
1434 2379
1437Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2382Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
1438can be C<undef>. Does the right thing when the player is currently in a 2383can be C<undef>. Does the right thing when the player is currently in a
1439dialogue with the given NPC character. 2384dialogue with the given NPC character.
1440 2385
1441=cut 2386=cut
2387
2388our $SAY_CHANNEL = {
2389 id => "say",
2390 title => "Map",
2391 reply => "say ",
2392 tooltip => "Things said to and replied from npcs near you and other players on the same map only.",
2393};
2394
2395our $CHAT_CHANNEL = {
2396 id => "chat",
2397 title => "Chat",
2398 reply => "chat ",
2399 tooltip => "Player chat and shouts, global to the server.",
2400};
1442 2401
1443# rough implementation of a future "reply" method that works 2402# rough implementation of a future "reply" method that works
1444# with dialog boxes. 2403# with dialog boxes.
1445#TODO: the first argument must go, split into a $npc->reply_to ( method 2404#TODO: the first argument must go, split into a $npc->reply_to ( method
1446sub cf::object::player::reply($$$;$) { 2405sub cf::object::player::reply($$$;$) {
1448 2407
1449 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2408 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1450 2409
1451 if ($self->{record_replies}) { 2410 if ($self->{record_replies}) {
1452 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2411 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2412
1453 } else { 2413 } else {
2414 my $pl = $self->contr;
2415
2416 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2417 my $dialog = $pl->{npc_dialog};
2418 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2419
2420 } else {
1454 $msg = $npc->name . " says: $msg" if $npc; 2421 $msg = $npc->name . " says: $msg" if $npc;
1455 $self->message ($msg, $flags); 2422 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2423 }
1456 } 2424 }
2425}
2426
2427=item $object->send_msg ($channel, $msg, $color, [extra...])
2428
2429=cut
2430
2431sub cf::object::send_msg {
2432 my $pl = shift->contr
2433 or return;
2434 $pl->send_msg (@_);
1457} 2435}
1458 2436
1459=item $player_object->may ("access") 2437=item $player_object->may ("access")
1460 2438
1461Returns wether the given player is authorized to access resource "access" 2439Returns wether the given player is authorized to access resource "access"
1474 2452
1475=item $player_object->enter_link 2453=item $player_object->enter_link
1476 2454
1477Freezes the player and moves him/her to a special map (C<{link}>). 2455Freezes the player and moves him/her to a special map (C<{link}>).
1478 2456
1479The player should be reaosnably safe there for short amounts of time. You 2457The player should be reasonably safe there for short amounts of time (e.g.
1480I<MUST> call C<leave_link> as soon as possible, though. 2458for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2459though, as the palyer cannot control the character while it is on the link
2460map.
2461
2462Will never block.
1481 2463
1482=item $player_object->leave_link ($map, $x, $y) 2464=item $player_object->leave_link ($map, $x, $y)
1483 2465
1484Moves the player out of the specila link map onto the given map. If the 2466Moves the player out of the special C<{link}> map onto the specified
1485map is not valid (or omitted), the player will be moved back to the 2467map. If the map is not valid (or omitted), the player will be moved back
1486location he/she was before the call to C<enter_link>, or, if that fails, 2468to the location he/she was before the call to C<enter_link>, or, if that
1487to the emergency map position. 2469fails, to the emergency map position.
1488 2470
1489Might block. 2471Might block.
1490 2472
1491=cut 2473=cut
2474
2475sub link_map {
2476 unless ($LINK_MAP) {
2477 $LINK_MAP = cf::map::find "{link}"
2478 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
2479 $LINK_MAP->load;
2480 }
2481
2482 $LINK_MAP
2483}
1492 2484
1493sub cf::object::player::enter_link { 2485sub cf::object::player::enter_link {
1494 my ($self) = @_; 2486 my ($self) = @_;
1495 2487
1496 $self->deactivate_recursive; 2488 $self->deactivate_recursive;
1497 2489
1498 return if $self->map == $LINK_MAP; 2490 return if UNIVERSAL::isa $self->map, "ext::map_link";
1499 2491
1500 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2492 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1501 if $self->map; 2493 if $self->map && $self->map->{path} ne "{link}";
1502 2494
1503 $self->enter_map ($LINK_MAP, 20, 20); 2495 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1504} 2496}
1505 2497
1506sub cf::object::player::leave_link { 2498sub cf::object::player::leave_link {
1507 my ($self, $map, $x, $y) = @_; 2499 my ($self, $map, $x, $y) = @_;
2500
2501 return unless $self->contr->active;
1508 2502
1509 my $link_pos = delete $self->{_link_pos}; 2503 my $link_pos = delete $self->{_link_pos};
1510 2504
1511 unless ($map) { 2505 unless ($map) {
1512 # restore original map position 2506 # restore original map position
1513 ($map, $x, $y) = @{ $link_pos || [] }; 2507 ($map, $x, $y) = @{ $link_pos || [] };
1514 $map = cf::map::find_map $map; 2508 $map = cf::map::find $map;
1515 2509
1516 unless ($map) { 2510 unless ($map) {
1517 ($map, $x, $y) = @$EMERGENCY_POSITION; 2511 ($map, $x, $y) = @$EMERGENCY_POSITION;
1518 $map = cf::map::find_map $map 2512 $map = cf::map::find $map
1519 or die "FATAL: cannot load emergency map\n"; 2513 or die "FATAL: cannot load emergency map\n";
1520 } 2514 }
1521 } 2515 }
1522 2516
1523 ($x, $y) = (-1, -1) 2517 ($x, $y) = (-1, -1)
1526 # use -1 or undef as default coordinates, not 0, 0 2520 # use -1 or undef as default coordinates, not 0, 0
1527 ($x, $y) = ($map->enter_x, $map->enter_y) 2521 ($x, $y) = ($map->enter_x, $map->enter_y)
1528 if $x <=0 && $y <= 0; 2522 if $x <=0 && $y <= 0;
1529 2523
1530 $map->load; 2524 $map->load;
2525 $map->load_neighbours;
1531 2526
2527 return unless $self->contr->active;
2528 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
1532 $self->activate_recursive; 2529 $self->activate_recursive;
2530
2531 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1533 $self->enter_map ($map, $x, $y); 2532 $self->enter_map ($map, $x, $y);
1534} 2533}
1535 2534
1536cf::player->attach ( 2535=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1537 on_logout => sub {
1538 my ($pl) = @_;
1539 2536
1540 # abort map switching before logout 2537Moves the player to the given map-path and coordinates by first freezing
1541 if ($pl->ob->{_link_pos}) { 2538her, loading and preparing them map, calling the provided $check callback
1542 cf::sync_job { 2539that has to return the map if sucecssful, and then unfreezes the player on
1543 $pl->ob->leave_link 2540the new (success) or old (failed) map position. In either case, $done will
1544 }; 2541be called at the end of this process.
1545 }
1546 },
1547 on_login => sub {
1548 my ($pl) = @_;
1549 2542
1550 # try to abort aborted map switching on player login :) 2543Note that $check will be called with a potentially non-loaded map, so if
1551 # should happen only on crashes 2544it needs a loaded map it has to call C<< ->load >>.
1552 if ($pl->ob->{_link_pos}) {
1553 $pl->ob->enter_link;
1554 cf::async {
1555 # we need this sleep as the login has a concurrent enter_exit running
1556 # and this sleep increases chances of the player not ending up in scorn
1557 Coro::Timer::sleep 1;
1558 $pl->ob->leave_link;
1559 };
1560 }
1561 },
1562);
1563 2545
1564=item $player_object->goto_map ($path, $x, $y)
1565
1566=cut 2546=cut
1567 2547
2548our $GOTOGEN;
2549
1568sub cf::object::player::goto_map { 2550sub cf::object::player::goto {
1569 my ($self, $path, $x, $y) = @_; 2551 my ($self, $path, $x, $y, $check, $done) = @_;
2552
2553 # do generation counting so two concurrent goto's will be executed in-order
2554 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1570 2555
1571 $self->enter_link; 2556 $self->enter_link;
1572 2557
1573 (cf::async { 2558 (async {
1574 $path = new cf::path $path; 2559 $Coro::current->{desc} = "player::goto $path $x $y";
1575 2560
1576 my $map = cf::map::find_map $path->as_string; 2561 # *tag paths override both path and x|y
2562 if ($path =~ /^\*(.*)$/) {
2563 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2564 my $ob = $obs[rand @obs];
2565
2566 # see if we actually can go there
2567 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2568 $ob = $obs[rand @obs];
2569 } else {
2570 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2571 }
2572 # else put us there anyways for now #d#
2573
2574 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2575 } else {
2576 ($path, $x, $y) = (undef, undef, undef);
2577 }
2578 }
2579
2580 my $map = eval {
2581 my $map = defined $path ? cf::map::find $path : undef;
2582
2583 if ($map) {
1577 $map = $map->customise_for ($self) if $map; 2584 $map = $map->customise_for ($self);
1578 2585 $map = $check->($map) if $check && $map;
1579# warn "entering ", $map->path, " at ($x, $y)\n" 2586 } else {
1580# if $map;
1581
1582 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2587 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2588 }
1583 2589
2590 $map
2591 };
2592
2593 if ($@) {
2594 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2595 LOG llevError | logBacktrace, Carp::longmess $@;
2596 }
2597
2598 if ($gen == $self->{_goto_generation}) {
2599 delete $self->{_goto_generation};
1584 $self->leave_link ($map, $x, $y); 2600 $self->leave_link ($map, $x, $y);
2601 }
2602
2603 $done->() if $done;
1585 })->prio (1); 2604 })->prio (1);
1586} 2605}
1587 2606
1588=item $player_object->enter_exit ($exit_object) 2607=item $player_object->enter_exit ($exit_object)
1589 2608
1591 2610
1592sub parse_random_map_params { 2611sub parse_random_map_params {
1593 my ($spec) = @_; 2612 my ($spec) = @_;
1594 2613
1595 my $rmp = { # defaults 2614 my $rmp = { # defaults
1596 xsize => 10, 2615 xsize => (cf::rndm 15, 40),
1597 ysize => 10, 2616 ysize => (cf::rndm 15, 40),
2617 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2618 #layout => string,
1598 }; 2619 };
1599 2620
1600 for (split /\n/, $spec) { 2621 for (split /\n/, $spec) {
1601 my ($k, $v) = split /\s+/, $_, 2; 2622 my ($k, $v) = split /\s+/, $_, 2;
1602 2623
1614 # that depends on the exit object 2635 # that depends on the exit object
1615 2636
1616 my $rmp = parse_random_map_params $exit->msg; 2637 my $rmp = parse_random_map_params $exit->msg;
1617 2638
1618 if ($exit->map) { 2639 if ($exit->map) {
1619 $rmp->{region} = $exit->map->region_name; 2640 $rmp->{region} = $exit->region->name;
1620 $rmp->{origin_map} = $exit->map->path; 2641 $rmp->{origin_map} = $exit->map->path;
1621 $rmp->{origin_x} = $exit->x; 2642 $rmp->{origin_x} = $exit->x;
1622 $rmp->{origin_y} = $exit->y; 2643 $rmp->{origin_y} = $exit->y;
2644
2645 $exit->map->touch;
1623 } 2646 }
1624 2647
1625 $rmp->{random_seed} ||= $exit->random_seed; 2648 $rmp->{random_seed} ||= $exit->random_seed;
1626 2649
1627 my $data = cf::to_json $rmp; 2650 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
1628 my $md5 = Digest::MD5::md5_hex $data; 2651 my $md5 = Digest::MD5::md5_hex $data;
2652 my $meta = "$RANDOMDIR/$md5.meta";
1629 2653
1630 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) { 2654 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1631 aio_write $fh, 0, (length $data), $data, 0; 2655 aio_write $fh, 0, (length $data), $data, 0;
2656 undef $fh;
2657 aio_rename "$meta~", $meta;
1632 2658
2659 my $slaying = "?random/$md5";
2660
2661 if ($exit->valid) {
1633 $exit->slaying ("?random/$md5"); 2662 $exit->slaying ("?random/$md5");
1634 $exit->msg (undef); 2663 $exit->msg (undef);
2664 }
1635 } 2665 }
1636} 2666}
1637 2667
1638sub cf::object::player::enter_exit { 2668sub cf::object::player::enter_exit {
1639 my ($self, $exit) = @_; 2669 my ($self, $exit) = @_;
1640 2670
1641 return unless $self->type == cf::PLAYER; 2671 return unless $self->type == cf::PLAYER;
1642 2672
1643 $self->enter_link; 2673 $self->enter_link;
1644 2674
1645 (cf::async { 2675 (async {
2676 $Coro::current->{desc} = "enter_exit";
2677
1646 unless (eval { 2678 unless (eval {
2679 $self->deactivate_recursive; # just to be sure
2680
2681 # random map handling
2682 {
2683 my $guard = cf::lock_acquire "exit_prepare:$exit";
2684
1647 prepare_random_map $exit 2685 prepare_random_map $exit
1648 if $exit->slaying eq "/!"; 2686 if $exit->slaying eq "/!";
2687 }
1649 2688
1650 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path; 2689 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1651 $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp); 2690 my $x = $exit->stats->hp;
2691 my $y = $exit->stats->sp;
1652 2692
2693 $self->goto ($map, $x, $y);
2694
2695 # if exit is damned, update players death & WoR home-position
2696 $self->contr->savebed ($map, $x, $y)
2697 if $exit->flag (cf::FLAG_DAMNED);
2698
1653 1; 2699 1
1654 }) { 2700 }) {
1655 $self->message ("Something went wrong deep within the crossfire server. " 2701 $self->message ("Something went wrong deep within the deliantra server. "
1656 . "I'll try to bring you back to the map you were before. " 2702 . "I'll try to bring you back to the map you were before. "
1657 . "Please report this to the dungeon master", 2703 . "Please report this to the dungeon master!",
1658 cf::NDI_UNIQUE | cf::NDI_RED); 2704 cf::NDI_UNIQUE | cf::NDI_RED);
1659 2705
1660 warn "ERROR in enter_exit: $@"; 2706 warn "ERROR in enter_exit: $@";
1661 $self->leave_link; 2707 $self->leave_link;
1662 } 2708 }
1663 })->prio (1); 2709 })->prio (1);
1676 2722
1677sub cf::client::send_drawinfo { 2723sub cf::client::send_drawinfo {
1678 my ($self, $text, $flags) = @_; 2724 my ($self, $text, $flags) = @_;
1679 2725
1680 utf8::encode $text; 2726 utf8::encode $text;
1681 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2727 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1682} 2728}
1683 2729
2730=item $client->send_msg ($channel, $msg, $color, [extra...])
2731
2732Send a drawinfo or msg packet to the client, formatting the msg for the
2733client if neccessary. C<$type> should be a string identifying the type of
2734the message, with C<log> being the default. If C<$color> is negative, suppress
2735the message unless the client supports the msg packet.
2736
2737=cut
2738
2739# non-persistent channels (usually the info channel)
2740our %CHANNEL = (
2741 "c/identify" => {
2742 id => "infobox",
2743 title => "Identify",
2744 reply => undef,
2745 tooltip => "Items recently identified",
2746 },
2747 "c/examine" => {
2748 id => "infobox",
2749 title => "Examine",
2750 reply => undef,
2751 tooltip => "Signs and other items you examined",
2752 },
2753 "c/book" => {
2754 id => "infobox",
2755 title => "Book",
2756 reply => undef,
2757 tooltip => "The contents of a note or book",
2758 },
2759 "c/lookat" => {
2760 id => "infobox",
2761 title => "Look",
2762 reply => undef,
2763 tooltip => "What you saw there",
2764 },
2765 "c/who" => {
2766 id => "infobox",
2767 title => "Players",
2768 reply => undef,
2769 tooltip => "Shows players who are currently online",
2770 },
2771 "c/body" => {
2772 id => "infobox",
2773 title => "Body Parts",
2774 reply => undef,
2775 tooltip => "Shows which body parts you posess and are available",
2776 },
2777 "c/skills" => {
2778 id => "infobox",
2779 title => "Skills",
2780 reply => undef,
2781 tooltip => "Shows your experience per skill and item power",
2782 },
2783 "c/uptime" => {
2784 id => "infobox",
2785 title => "Uptime",
2786 reply => undef,
2787 tooltip => "How long the server has been running since last restart",
2788 },
2789 "c/mapinfo" => {
2790 id => "infobox",
2791 title => "Map Info",
2792 reply => undef,
2793 tooltip => "Information related to the maps",
2794 },
2795 "c/party" => {
2796 id => "party",
2797 title => "Party",
2798 reply => "gsay ",
2799 tooltip => "Messages and chat related to your party",
2800 },
2801);
2802
2803sub cf::client::send_msg {
2804 my ($self, $channel, $msg, $color, @extra) = @_;
2805
2806 $msg = $self->pl->expand_cfpod ($msg)
2807 unless $color & cf::NDI_VERBATIM;
2808
2809 $color &= cf::NDI_CLIENT_MASK; # just in case...
2810
2811 # check predefined channels, for the benefit of C
2812 if ($CHANNEL{$channel}) {
2813 $channel = $CHANNEL{$channel};
2814
2815 $self->ext_msg (channel_info => $channel)
2816 if $self->can_msg;
2817
2818 $channel = $channel->{id};
2819
2820 } elsif (ref $channel) {
2821 # send meta info to client, if not yet sent
2822 unless (exists $self->{channel}{$channel->{id}}) {
2823 $self->{channel}{$channel->{id}} = $channel;
2824 $self->ext_msg (channel_info => $channel)
2825 if $self->can_msg;
2826 }
2827
2828 $channel = $channel->{id};
2829 }
2830
2831 return unless @extra || length $msg;
2832
2833 if ($self->can_msg) {
2834 # default colour, mask it out
2835 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2836 if $color & cf::NDI_DEF;
2837
2838 my $pkt = "msg "
2839 . $self->{json_coder}->encode (
2840 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2841 );
2842
2843 # try lzf for large packets
2844 $pkt = "lzf " . Compress::LZF::compress $pkt
2845 if 1024 <= length $pkt and $self->{can_lzf};
2846
2847 # split very large packets
2848 if (8192 < length $pkt and $self->{can_lzf}) {
2849 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2850 $pkt = "frag";
2851 }
2852
2853 $self->send_packet ($pkt);
2854 } else {
2855 if ($color >= 0) {
2856 # replace some tags by gcfclient-compatible ones
2857 for ($msg) {
2858 1 while
2859 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2860 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2861 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2862 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2863 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2864 }
2865
2866 $color &= cf::NDI_COLOR_MASK;
2867
2868 utf8::encode $msg;
2869
2870 if (0 && $msg =~ /\[/) {
2871 # COMMAND/INFO
2872 $self->send_packet ("drawextinfo $color 10 8 $msg")
2873 } else {
2874 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2875 $self->send_packet ("drawinfo $color $msg")
2876 }
2877 }
2878 }
2879}
2880
2881=item $client->ext_msg ($type, @msg)
2882
2883Sends an ext event to the client.
2884
2885=cut
2886
2887sub cf::client::ext_msg($$@) {
2888 my ($self, $type, @msg) = @_;
2889
2890 if ($self->extcmd == 2) {
2891 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2892 } elsif ($self->extcmd == 1) { # TODO: remove
2893 push @msg, msgtype => "event_$type";
2894 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2895 }
2896}
2897
2898=item $client->ext_reply ($msgid, @msg)
2899
2900Sends an ext reply to the client.
2901
2902=cut
2903
2904sub cf::client::ext_reply($$@) {
2905 my ($self, $id, @msg) = @_;
2906
2907 if ($self->extcmd == 2) {
2908 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2909 } elsif ($self->extcmd == 1) {
2910 #TODO: version 1, remove
2911 unshift @msg, msgtype => "reply", msgid => $id;
2912 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2913 }
2914}
1684 2915
1685=item $success = $client->query ($flags, "text", \&cb) 2916=item $success = $client->query ($flags, "text", \&cb)
1686 2917
1687Queues a query to the client, calling the given callback with 2918Queues a query to the client, calling the given callback with
1688the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2919the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1689C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2920C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1690 2921
1691Queries can fail, so check the return code. Or don't, as queries will become 2922Queries can fail, so check the return code. Or don't, as queries will
1692reliable at some point in the future. 2923become reliable at some point in the future.
1693 2924
1694=cut 2925=cut
1695 2926
1696sub cf::client::query { 2927sub cf::client::query {
1697 my ($self, $flags, $text, $cb) = @_; 2928 my ($self, $flags, $text, $cb) = @_;
1705 utf8::encode $text; 2936 utf8::encode $text;
1706 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2937 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1707 2938
1708 $self->send_packet ($self->{query_queue}[0][0]) 2939 $self->send_packet ($self->{query_queue}[0][0])
1709 if @{ $self->{query_queue} } == 1; 2940 if @{ $self->{query_queue} } == 1;
2941
2942 1
1710} 2943}
1711 2944
1712cf::client->attach ( 2945cf::client->attach (
2946 on_connect => sub {
2947 my ($ns) = @_;
2948
2949 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2950 },
1713 on_reply => sub { 2951 on_reply => sub {
1714 my ($ns, $msg) = @_; 2952 my ($ns, $msg) = @_;
1715 2953
1716 # this weird shuffling is so that direct followup queries 2954 # this weird shuffling is so that direct followup queries
1717 # get handled first 2955 # get handled first
1718 my $queue = delete $ns->{query_queue} 2956 my $queue = delete $ns->{query_queue}
1719 or return; # be conservative, not sure how that cna happen, but we saw a crash here 2957 or return; # be conservative, not sure how that can happen, but we saw a crash here
1720 2958
1721 (shift @$queue)->[1]->($msg); 2959 (shift @$queue)->[1]->($msg);
2960 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1722 2961
1723 push @{ $ns->{query_queue} }, @$queue; 2962 push @{ $ns->{query_queue} }, @$queue;
1724 2963
1725 if (@{ $ns->{query_queue} } == @$queue) { 2964 if (@{ $ns->{query_queue} } == @$queue) {
1726 if (@$queue) { 2965 if (@$queue) {
1728 } else { 2967 } else {
1729 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2968 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1730 } 2969 }
1731 } 2970 }
1732 }, 2971 },
2972 on_exticmd => sub {
2973 my ($ns, $buf) = @_;
2974
2975 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2976
2977 if (ref $msg) {
2978 my ($type, $reply, @payload) =
2979 "ARRAY" eq ref $msg
2980 ? @$msg
2981 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2982
2983 my @reply;
2984
2985 if (my $cb = $EXTICMD{$type}) {
2986 @reply = $cb->($ns, @payload);
2987 }
2988
2989 $ns->ext_reply ($reply, @reply)
2990 if $reply;
2991
2992 } else {
2993 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2994 }
2995
2996 cf::override;
2997 },
1733); 2998);
1734 2999
1735=item $client->coro (\&cb) 3000=item $client->async (\&cb)
1736 3001
1737Create a new coroutine, running the specified callback. The coroutine will 3002Create a new coroutine, running the specified callback. The coroutine will
1738be automatically cancelled when the client gets destroyed (e.g. on logout, 3003be automatically cancelled when the client gets destroyed (e.g. on logout,
1739or loss of connection). 3004or loss of connection).
1740 3005
1741=cut 3006=cut
1742 3007
1743sub cf::client::coro { 3008sub cf::client::async {
1744 my ($self, $cb) = @_; 3009 my ($self, $cb) = @_;
1745 3010
1746 my $coro = &cf::async ($cb); 3011 my $coro = &Coro::async ($cb);
1747 3012
1748 $coro->on_destroy (sub { 3013 $coro->on_destroy (sub {
1749 delete $self->{_coro}{$coro+0}; 3014 delete $self->{_coro}{$coro+0};
1750 }); 3015 });
1751 3016
1778our $safe = new Safe "safe"; 3043our $safe = new Safe "safe";
1779our $safe_hole = new Safe::Hole; 3044our $safe_hole = new Safe::Hole;
1780 3045
1781$SIG{FPE} = 'IGNORE'; 3046$SIG{FPE} = 'IGNORE';
1782 3047
1783$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3048$safe->permit_only (Opcode::opset qw(
3049 :base_core :base_mem :base_orig :base_math
3050 grepstart grepwhile mapstart mapwhile
3051 sort time
3052));
1784 3053
1785# here we export the classes and methods available to script code 3054# here we export the classes and methods available to script code
1786 3055
1787=pod 3056=pod
1788 3057
1789The following fucntions and emthods are available within a safe environment: 3058The following functions and methods are available within a safe environment:
1790 3059
1791 cf::object contr pay_amount pay_player map 3060 cf::object
3061 contr pay_amount pay_player map x y force_find force_add destroy
3062 insert remove name archname title slaying race decrease split
3063
1792 cf::object::player player 3064 cf::object::player
1793 cf::player peaceful 3065 player
1794 cf::map trigger 3066
3067 cf::player
3068 peaceful
3069
3070 cf::map
3071 trigger
1795 3072
1796=cut 3073=cut
1797 3074
1798for ( 3075for (
1799 ["cf::object" => qw(contr pay_amount pay_player map)], 3076 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3077 insert remove inv nrof name archname title slaying race
3078 decrease split destroy change_exp)],
1800 ["cf::object::player" => qw(player)], 3079 ["cf::object::player" => qw(player)],
1801 ["cf::player" => qw(peaceful)], 3080 ["cf::player" => qw(peaceful)],
1802 ["cf::map" => qw(trigger)], 3081 ["cf::map" => qw(trigger)],
1803) { 3082) {
1804 no strict 'refs'; 3083 no strict 'refs';
1875=back 3154=back
1876 3155
1877=cut 3156=cut
1878 3157
1879############################################################################# 3158#############################################################################
3159# the server's init and main functions
1880 3160
1881=head2 EXTENSION DATABASE SUPPORT 3161sub load_facedata($) {
3162 my ($path) = @_;
1882 3163
1883Crossfire maintains a very simple database for extension use. It can 3164 # HACK to clear player env face cache, we need some signal framework
1884currently store anything that can be serialised using Storable, which 3165 # for this (global event?)
1885excludes objects. 3166 %ext::player_env::MUSIC_FACE_CACHE = ();
1886 3167
1887The parameter C<$family> should best start with the name of the extension 3168 my $enc = JSON::XS->new->utf8->canonical->relaxed;
1888using it, it should be unique.
1889 3169
1890=over 4 3170 warn "loading facedata from $path\n";
1891 3171
1892=item $hashref = cf::db_get $family 3172 my $facedata;
3173 0 < aio_load $path, $facedata
3174 or die "$path: $!";
1893 3175
1894Return a hashref for use by the extension C<$family>, which can be 3176 $facedata = Coro::Storable::thaw $facedata;
1895modified. After modifications, you have to call C<cf::db_dirty> or
1896C<cf::db_sync>.
1897 3177
1898=item $value = cf::db_get $family => $key 3178 $facedata->{version} == 2
3179 or cf::cleanup "$path: version mismatch, cannot proceed.";
1899 3180
1900Returns a single value from the database 3181 # patch in the exptable
1901 3182 $facedata->{resource}{"res/exp_table"} = {
1902=item cf::db_put $family => $hashref 3183 type => FT_RSRC,
1903 3184 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
1904Stores the given family hashref into the database. Updates are delayed, if
1905you want the data to be synced to disk immediately, use C<cf::db_sync>.
1906
1907=item cf::db_put $family => $key => $value
1908
1909Stores the given C<$value> in the family hash. Updates are delayed, if you
1910want the data to be synced to disk immediately, use C<cf::db_sync>.
1911
1912=item cf::db_dirty
1913
1914Marks the database as dirty, to be updated at a later time.
1915
1916=item cf::db_sync
1917
1918Immediately write the database to disk I<if it is dirty>.
1919
1920=cut
1921
1922our $DB;
1923
1924{
1925 my $path = cf::localdir . "/database.pst";
1926
1927 sub db_load() {
1928 $DB = stat $path ? Storable::retrieve $path : { };
1929 }
1930
1931 my $pid;
1932
1933 sub db_save() {
1934 waitpid $pid, 0 if $pid;
1935 if (0 == ($pid = fork)) {
1936 $DB->{_meta}{version} = 1;
1937 Storable::nstore $DB, "$path~";
1938 rename "$path~", $path;
1939 cf::_exit 0 if defined $pid;
1940 }
1941 }
1942
1943 my $dirty;
1944
1945 sub db_sync() {
1946 db_save if $dirty;
1947 undef $dirty;
1948 }
1949
1950 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1951 db_sync;
1952 }); 3185 };
3186 cf::cede_to_tick;
1953 3187
1954 sub db_dirty() {
1955 $dirty = 1;
1956 $idle->start;
1957 } 3188 {
3189 my $faces = $facedata->{faceinfo};
1958 3190
1959 sub db_get($;$) { 3191 while (my ($face, $info) = each %$faces) {
1960 @_ >= 2 3192 my $idx = (cf::face::find $face) || cf::face::alloc $face;
1961 ? $DB->{$_[0]}{$_[1]}
1962 : ($DB->{$_[0]} ||= { })
1963 }
1964 3193
1965 sub db_put($$;$) { 3194 cf::face::set_visibility $idx, $info->{visibility};
1966 if (@_ >= 3) { 3195 cf::face::set_magicmap $idx, $info->{magicmap};
1967 $DB->{$_[0]}{$_[1]} = $_[2]; 3196 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
1968 } else { 3197 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
1969 $DB->{$_[0]} = $_[1];
1970 }
1971 db_dirty;
1972 }
1973 3198
1974 cf::global->attach ( 3199 cf::cede_to_tick;
1975 prio => 10000,
1976 on_cleanup => sub {
1977 db_sync;
1978 }, 3200 }
1979 );
1980}
1981 3201
1982############################################################################# 3202 while (my ($face, $info) = each %$faces) {
1983# the server's main() 3203 next unless $info->{smooth};
1984 3204
1985sub cfg_load { 3205 my $idx = cf::face::find $face
3206 or next;
3207
3208 if (my $smooth = cf::face::find $info->{smooth}) {
3209 cf::face::set_smooth $idx, $smooth;
3210 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3211 } else {
3212 warn "smooth face '$info->{smooth}' not found for face '$face'";
3213 }
3214
3215 cf::cede_to_tick;
3216 }
3217 }
3218
3219 {
3220 my $anims = $facedata->{animinfo};
3221
3222 while (my ($anim, $info) = each %$anims) {
3223 cf::anim::set $anim, $info->{frames}, $info->{facings};
3224 cf::cede_to_tick;
3225 }
3226
3227 cf::anim::invalidate_all; # d'oh
3228 }
3229
3230 {
3231 # TODO: for gcfclient pleasure, we should give resources
3232 # that gcfclient doesn't grok a >10000 face index.
3233 my $res = $facedata->{resource};
3234
3235 while (my ($name, $info) = each %$res) {
3236 if (defined $info->{type}) {
3237 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3238 my $data;
3239
3240 if ($info->{type} & 1) {
3241 # prepend meta info
3242
3243 my $meta = $enc->encode ({
3244 name => $name,
3245 %{ $info->{meta} || {} },
3246 });
3247
3248 $data = pack "(w/a*)*", $meta, $info->{data};
3249 } else {
3250 $data = $info->{data};
3251 }
3252
3253 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3254 cf::face::set_type $idx, $info->{type};
3255 } else {
3256 $RESOURCE{$name} = $info;
3257 }
3258
3259 cf::cede_to_tick;
3260 }
3261 }
3262
3263 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3264
3265 1
3266}
3267
3268cf::global->attach (on_resource_update => sub {
3269 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3270 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3271
3272 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3273 my $sound = $soundconf->{compat}[$_]
3274 or next;
3275
3276 my $face = cf::face::find "sound/$sound->[1]";
3277 cf::sound::set $sound->[0] => $face;
3278 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3279 }
3280
3281 while (my ($k, $v) = each %{$soundconf->{event}}) {
3282 my $face = cf::face::find "sound/$v";
3283 cf::sound::set $k => $face;
3284 }
3285 }
3286});
3287
3288register_exticmd fx_want => sub {
3289 my ($ns, $want) = @_;
3290
3291 while (my ($k, $v) = each %$want) {
3292 $ns->fx_want ($k, $v);
3293 }
3294};
3295
3296sub load_resource_file($) {
3297 my $guard = lock_acquire "load_resource_file";
3298
3299 my $status = load_resource_file_ $_[0];
3300 get_slot 0.1, 100;
3301 cf::arch::commit_load;
3302
3303 $status
3304}
3305
3306sub reload_regions {
3307 # HACK to clear player env face cache, we need some signal framework
3308 # for this (global event?)
3309 %ext::player_env::MUSIC_FACE_CACHE = ();
3310
3311 load_resource_file "$MAPDIR/regions"
3312 or die "unable to load regions file\n";
3313
3314 for (cf::region::list) {
3315 $_->{match} = qr/$_->{match}/
3316 if exists $_->{match};
3317 }
3318}
3319
3320sub reload_facedata {
3321 load_facedata "$DATADIR/facedata"
3322 or die "unable to load facedata\n";
3323}
3324
3325sub reload_archetypes {
3326 load_resource_file "$DATADIR/archetypes"
3327 or die "unable to load archetypes\n";
3328}
3329
3330sub reload_treasures {
3331 load_resource_file "$DATADIR/treasures"
3332 or die "unable to load treasurelists\n";
3333}
3334
3335sub reload_resources {
3336 warn "reloading resource files...\n";
3337
3338 reload_facedata;
3339 reload_archetypes;
3340 reload_regions;
3341 reload_treasures;
3342
3343 warn "finished reloading resource files\n";
3344}
3345
3346sub init {
3347 my $guard = freeze_mainloop;
3348
3349 evthread_start IO::AIO::poll_fileno;
3350
3351 reload_resources;
3352}
3353
3354sub reload_config {
1986 open my $fh, "<:utf8", cf::confdir . "/config" 3355 open my $fh, "<:utf8", "$CONFDIR/config"
1987 or return; 3356 or return;
1988 3357
1989 local $/; 3358 local $/;
1990 *CFG = YAML::Syck::Load <$fh>; 3359 *CFG = YAML::Load <$fh>;
3360
3361 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3362
3363 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3364 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3365
3366 if (exists $CFG{mlockall}) {
3367 eval {
3368 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3369 and die "WARNING: m(un)lockall failed: $!\n";
3370 };
3371 warn $@ if $@;
3372 }
3373}
3374
3375sub pidfile() {
3376 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3377 or die "$PIDFILE: $!";
3378 flock $fh, &Fcntl::LOCK_EX
3379 or die "$PIDFILE: flock: $!";
3380 $fh
3381}
3382
3383# make sure only one server instance is running at any one time
3384sub atomic {
3385 my $fh = pidfile;
3386
3387 my $pid = <$fh>;
3388 kill 9, $pid if $pid > 0;
3389
3390 seek $fh, 0, 0;
3391 print $fh $$;
1991} 3392}
1992 3393
1993sub main { 3394sub main {
3395 atomic;
3396
1994 # we must not ever block the main coroutine 3397 # we must not ever block the main coroutine
1995 local $Coro::idle = sub { 3398 local $Coro::idle = sub {
1996 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3399 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
1997 (Coro::unblock_sub { 3400 (async {
1998 Event::one_event; 3401 $Coro::current->{desc} = "IDLE BUG HANDLER";
1999 })->(); 3402 EV::loop EV::LOOP_ONESHOT;
3403 })->prio (Coro::PRIO_MAX);
2000 }; 3404 };
2001 3405
2002 cfg_load; 3406 {
2003 db_load; 3407 my $guard = freeze_mainloop;
3408 reload_config;
3409 db_init;
2004 load_extensions; 3410 load_extensions;
3411
3412 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3413 }
3414
3415 utime time, time, $RUNTIMEFILE;
3416
3417 # no (long-running) fork's whatsoever before this point(!)
3418 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3419
2005 Event::loop; 3420 EV::loop;
2006} 3421}
2007 3422
2008############################################################################# 3423#############################################################################
2009# initialisation 3424# initialisation and cleanup
2010 3425
3426# install some emergency cleanup handlers
3427BEGIN {
3428 our %SIGWATCHER = ();
3429 for my $signal (qw(INT HUP TERM)) {
3430 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3431 cf::cleanup "SIG$signal";
3432 };
3433 }
3434}
3435
3436sub write_runtime_sync {
3437 # first touch the runtime file to show we are still running:
3438 # the fsync below can take a very very long time.
3439
3440 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3441
3442 my $guard = cf::lock_acquire "write_runtime";
3443
3444 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3445 or return;
3446
3447 my $value = $cf::RUNTIME + 90 + 10;
3448 # 10 is the runtime save interval, for a monotonic clock
3449 # 60 allows for the watchdog to kill the server.
3450
3451 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3452 and return;
3453
3454 # always fsync - this file is important
3455 aio_fsync $fh
3456 and return;
3457
3458 # touch it again to show we are up-to-date
3459 aio_utime $fh, undef, undef;
3460
3461 close $fh
3462 or return;
3463
3464 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3465 and return;
3466
3467 warn "runtime file written.\n";
3468
3469 1
3470}
3471
3472our $uuid_lock;
3473our $uuid_skip;
3474
3475sub write_uuid_sync($) {
3476 $uuid_skip ||= $_[0];
3477
3478 return if $uuid_lock;
3479 local $uuid_lock = 1;
3480
3481 my $uuid = "$LOCALDIR/uuid";
3482
3483 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3484 or return;
3485
3486 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;
3487 $uuid_skip = 0;
3488
3489 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3490 and return;
3491
3492 # always fsync - this file is important
3493 aio_fsync $fh
3494 and return;
3495
3496 close $fh
3497 or return;
3498
3499 aio_rename "$uuid~", $uuid
3500 and return;
3501
3502 warn "uuid file written ($value).\n";
3503
3504 1
3505
3506}
3507
3508sub write_uuid($$) {
3509 my ($skip, $sync) = @_;
3510
3511 $sync ? write_uuid_sync $skip
3512 : async { write_uuid_sync $skip };
3513}
3514
3515sub emergency_save() {
3516 my $freeze_guard = cf::freeze_mainloop;
3517
3518 warn "enter emergency perl save\n";
3519
3520 cf::sync_job {
3521 # use a peculiar iteration method to avoid tripping on perl
3522 # refcount bugs in for. also avoids problems with players
3523 # and maps saved/destroyed asynchronously.
3524 warn "begin emergency player save\n";
3525 for my $login (keys %cf::PLAYER) {
3526 my $pl = $cf::PLAYER{$login} or next;
3527 $pl->valid or next;
3528 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3529 $pl->save;
3530 }
3531 warn "end emergency player save\n";
3532
3533 warn "begin emergency map save\n";
3534 for my $path (keys %cf::MAP) {
3535 my $map = $cf::MAP{$path} or next;
3536 $map->valid or next;
3537 $map->save;
3538 }
3539 warn "end emergency map save\n";
3540
3541 warn "begin emergency database checkpoint\n";
3542 BDB::db_env_txn_checkpoint $DB_ENV;
3543 warn "end emergency database checkpoint\n";
3544
3545 warn "begin write uuid\n";
3546 write_uuid_sync 1;
3547 warn "end write uuid\n";
3548 };
3549
3550 warn "leave emergency perl save\n";
3551}
3552
3553sub post_cleanup {
3554 my ($make_core) = @_;
3555
3556 warn Carp::longmess "post_cleanup backtrace"
3557 if $make_core;
3558
3559 my $fh = pidfile;
3560 unlink $PIDFILE if <$fh> == $$;
3561}
3562
3563# a safer delete_package, copied from Symbol
3564sub clear_package($) {
3565 my $pkg = shift;
3566
3567 # expand to full symbol table name if needed
3568 unless ($pkg =~ /^main::.*::$/) {
3569 $pkg = "main$pkg" if $pkg =~ /^::/;
3570 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3571 $pkg .= '::' unless $pkg =~ /::$/;
3572 }
3573
3574 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3575 my $stem_symtab = *{$stem}{HASH};
3576
3577 defined $stem_symtab and exists $stem_symtab->{$leaf}
3578 or return;
3579
3580 # clear all symbols
3581 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3582 for my $name (keys %$leaf_symtab) {
3583 _gv_clear *{"$pkg$name"};
3584# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3585 }
3586 warn "cleared package $pkg\n";#d#
3587}
3588
2011sub reload() { 3589sub do_reload_perl() {
2012 # can/must only be called in main 3590 # can/must only be called in main
2013 if ($Coro::current != $Coro::main) { 3591 if ($Coro::current != $Coro::main) {
2014 warn "can only reload from main coroutine\n"; 3592 warn "can only reload from main coroutine";
2015 return; 3593 return;
2016 } 3594 }
2017 3595
3596 return if $RELOAD++;
3597
3598 while ($RELOAD) {
2018 warn "reloading..."; 3599 warn "reloading...";
2019 3600
2020 local $FREEZE = 1; 3601 warn "entering sync_job";
3602
3603 cf::sync_job {
3604 cf::write_runtime_sync; # external watchdog should not bark
2021 cf::emergency_save; 3605 cf::emergency_save;
3606 cf::write_runtime_sync; # external watchdog should not bark
2022 3607
2023 eval { 3608 warn "syncing database to disk";
3609 BDB::db_env_txn_checkpoint $DB_ENV;
3610
2024 # if anything goes wrong in here, we should simply crash as we already saved 3611 # if anything goes wrong in here, we should simply crash as we already saved
2025 3612
2026 # cancel all watchers 3613 warn "flushing outstanding aio requests";
2027 for (Event::all_watchers) { 3614 while (IO::AIO::nreqs || BDB::nreqs) {
2028 $_->cancel if $_->data & WF_AUTOCANCEL; 3615 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
2029 }
2030
2031 # cancel all extension coros
2032 $_->cancel for values %EXT_CORO;
2033 %EXT_CORO = ();
2034
2035 # unload all extensions
2036 for (@exts) {
2037 warn "unloading <$_>";
2038 unload_extension $_;
2039 }
2040
2041 # unload all modules loaded from $LIBDIR
2042 while (my ($k, $v) = each %INC) {
2043 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2044
2045 warn "removing <$k>";
2046 delete $INC{$k};
2047
2048 $k =~ s/\.pm$//;
2049 $k =~ s/\//::/g;
2050
2051 if (my $cb = $k->can ("unload_module")) {
2052 $cb->();
2053 } 3616 }
2054 3617
2055 Symbol::delete_package $k; 3618 warn "cancelling all extension coros";
3619 $_->cancel for values %EXT_CORO;
3620 %EXT_CORO = ();
3621
3622 warn "removing commands";
3623 %COMMAND = ();
3624
3625 warn "removing ext/exti commands";
3626 %EXTCMD = ();
3627 %EXTICMD = ();
3628
3629 warn "unloading/nuking all extensions";
3630 for my $pkg (@EXTS) {
3631 warn "... unloading $pkg";
3632
3633 if (my $cb = $pkg->can ("unload")) {
3634 eval {
3635 $cb->($pkg);
3636 1
3637 } or warn "$pkg unloaded, but with errors: $@";
3638 }
3639
3640 warn "... clearing $pkg";
3641 clear_package $pkg;
2056 } 3642 }
2057 3643
2058 # sync database to disk 3644 warn "unloading all perl modules loaded from $LIBDIR";
2059 cf::db_sync; 3645 while (my ($k, $v) = each %INC) {
2060 IO::AIO::flush; 3646 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2061 3647
3648 warn "... unloading $k";
3649 delete $INC{$k};
3650
3651 $k =~ s/\.pm$//;
3652 $k =~ s/\//::/g;
3653
3654 if (my $cb = $k->can ("unload_module")) {
3655 $cb->();
3656 }
3657
3658 clear_package $k;
3659 }
3660
2062 # get rid of safe::, as good as possible 3661 warn "getting rid of safe::, as good as possible";
2063 Symbol::delete_package "safe::$_" 3662 clear_package "safe::$_"
2064 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3663 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2065 3664
2066 # remove register_script_function callbacks 3665 warn "unloading cf.pm \"a bit\"";
2067 # TODO
2068
2069 # unload cf.pm "a bit"
2070 delete $INC{"cf.pm"}; 3666 delete $INC{"cf.pm"};
3667 delete $INC{"cf/pod.pm"};
2071 3668
2072 # don't, removes xs symbols, too, 3669 # don't, removes xs symbols, too,
2073 # and global variables created in xs 3670 # and global variables created in xs
2074 #Symbol::delete_package __PACKAGE__; 3671 #clear_package __PACKAGE__;
2075 3672
2076 # reload cf.pm 3673 warn "unload completed, starting to reload now";
3674
2077 warn "reloading cf.pm"; 3675 warn "reloading cf.pm";
2078 require cf; 3676 require cf;
2079 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3677 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2080 3678
2081 # load config and database again 3679 warn "loading config and database again";
2082 cf::cfg_load; 3680 cf::reload_config;
2083 cf::db_load;
2084 3681
2085 # load extensions
2086 warn "load extensions"; 3682 warn "loading extensions";
2087 cf::load_extensions; 3683 cf::load_extensions;
2088 3684
2089 # reattach attachments to objects 3685 warn "reattaching attachments to objects/players";
3686 _global_reattach; # objects, sockets
3687 warn "reattaching attachments to maps";
3688 reattach $_ for values %MAP;
3689 warn "reattaching attachments to players";
3690 reattach $_ for values %PLAYER;
3691
3692 warn "leaving sync_job";
3693
3694 1
3695 } or do {
3696 warn $@;
3697 cf::cleanup "error while reloading, exiting.";
3698 };
3699
2090 warn "reattach"; 3700 warn "reloaded";
2091 _global_reattach; 3701 --$RELOAD;
3702 }
3703};
3704
3705our $RELOAD_WATCHER; # used only during reload
3706
3707sub reload_perl() {
3708 # doing reload synchronously and two reloads happen back-to-back,
3709 # coro crashes during coro_state_free->destroy here.
3710
3711 $RELOAD_WATCHER ||= EV::timer $TICK * 1.5, 0, sub {
3712 do_reload_perl;
3713 undef $RELOAD_WATCHER;
2092 }; 3714 };
2093
2094 if ($@) {
2095 warn $@;
2096 warn "error while reloading, exiting.";
2097 exit 1;
2098 }
2099
2100 warn "reloaded successfully";
2101};
2102
2103#############################################################################
2104
2105unless ($LINK_MAP) {
2106 $LINK_MAP = cf::map::new;
2107
2108 $LINK_MAP->width (41);
2109 $LINK_MAP->height (41);
2110 $LINK_MAP->alloc;
2111 $LINK_MAP->path ("{link}");
2112 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2113 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2114
2115 # dirty hack because... archetypes are not yet loaded
2116 Event->timer (
2117 after => 2,
2118 cb => sub {
2119 $_[0]->w->cancel;
2120
2121 # provide some exits "home"
2122 my $exit = cf::object::new "exit";
2123
2124 $exit->slaying ($EMERGENCY_POSITION->[0]);
2125 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2126 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2127
2128 $LINK_MAP->insert ($exit->clone, 19, 19);
2129 $LINK_MAP->insert ($exit->clone, 19, 20);
2130 $LINK_MAP->insert ($exit->clone, 19, 21);
2131 $LINK_MAP->insert ($exit->clone, 20, 19);
2132 $LINK_MAP->insert ($exit->clone, 20, 21);
2133 $LINK_MAP->insert ($exit->clone, 21, 19);
2134 $LINK_MAP->insert ($exit->clone, 21, 20);
2135 $LINK_MAP->insert ($exit->clone, 21, 21);
2136
2137 $exit->destroy;
2138 });
2139
2140 $LINK_MAP->{deny_save} = 1;
2141 $LINK_MAP->{deny_reset} = 1;
2142
2143 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2144} 3715}
2145
2146register "<global>", __PACKAGE__;
2147 3716
2148register_command "reload" => sub { 3717register_command "reload" => sub {
2149 my ($who, $arg) = @_; 3718 my ($who, $arg) = @_;
2150 3719
2151 if ($who->flag (FLAG_WIZ)) { 3720 if ($who->flag (FLAG_WIZ)) {
2152 $who->message ("start of reload.");
2153 reload;
2154 $who->message ("end of reload."); 3721 $who->message ("reloading server.");
3722 async {
3723 $Coro::current->{desc} = "perl_reload";
3724 reload_perl;
3725 };
2155 } 3726 }
2156}; 3727};
2157 3728
2158unshift @INC, $LIBDIR; 3729unshift @INC, $LIBDIR;
2159 3730
2160$TICK_WATCHER = Event->timer ( 3731my $bug_warning = 0;
2161 reentrant => 0, 3732
2162 prio => 0, 3733our @WAIT_FOR_TICK;
2163 at => $NEXT_TICK || $TICK, 3734our @WAIT_FOR_TICK_BEGIN;
2164 data => WF_AUTOCANCEL, 3735
2165 cb => sub { 3736sub wait_for_tick {
2166 unless ($FREEZE) { 3737 return if tick_inhibit || $Coro::current == $Coro::main;
3738
3739 my $signal = new Coro::Signal;
3740 push @WAIT_FOR_TICK, $signal;
3741 $signal->wait;
3742}
3743
3744sub wait_for_tick_begin {
3745 return if tick_inhibit || $Coro::current == $Coro::main;
3746
3747 my $signal = new Coro::Signal;
3748 push @WAIT_FOR_TICK_BEGIN, $signal;
3749 $signal->wait;
3750}
3751
3752sub tick {
3753 if ($Coro::current != $Coro::main) {
3754 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3755 unless ++$bug_warning > 10;
3756 return;
3757 }
3758
2167 cf::server_tick; # one server iteration 3759 cf::server_tick; # one server iteration
2168 $RUNTIME += $TICK;
2169 }
2170 3760
2171 $NEXT_TICK += $TICK; 3761 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2172 3762 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2173 # if we are delayed by four ticks or more, skip them all 3763 Coro::async_pool {
2174 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3764 $Coro::current->{desc} = "runtime saver";
2175
2176 $TICK_WATCHER->at ($NEXT_TICK);
2177 $TICK_WATCHER->start;
2178 },
2179);
2180
2181IO::AIO::max_poll_time $TICK * 0.2;
2182
2183Event->io (
2184 fd => IO::AIO::poll_fileno,
2185 poll => 'r',
2186 prio => 5,
2187 data => WF_AUTOCANCEL,
2188 cb => \&IO::AIO::poll_cb,
2189);
2190
2191Event->timer (
2192 data => WF_AUTOCANCEL,
2193 after => 0,
2194 interval => 10,
2195 cb => sub {
2196 (Coro::unblock_sub {
2197 write_runtime 3765 write_runtime_sync
2198 or warn "ERROR: unable to write runtime file: $!"; 3766 or warn "ERROR: unable to write runtime file: $!";
2199 })->(); 3767 };
2200 }, 3768 }
2201); 3769
3770 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3771 $sig->send;
3772 }
3773 while (my $sig = shift @WAIT_FOR_TICK) {
3774 $sig->send;
3775 }
3776
3777 $LOAD = ($NOW - $TICK_START) / $TICK;
3778 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3779
3780 if (0) {
3781 if ($NEXT_TICK) {
3782 my $jitter = $TICK_START - $NEXT_TICK;
3783 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3784 warn "jitter $JITTER\n";#d#
3785 }
3786 }
3787}
3788
3789{
3790 # configure BDB
3791
3792 BDB::min_parallel 8;
3793 BDB::max_poll_reqs $TICK * 0.1;
3794 $AnyEvent::BDB::WATCHER->priority (1);
3795
3796 unless ($DB_ENV) {
3797 $DB_ENV = BDB::db_env_create;
3798 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3799 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3800 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3801 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3802 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3803
3804 cf::sync_job {
3805 eval {
3806 BDB::db_env_open
3807 $DB_ENV,
3808 $BDBDIR,
3809 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3810 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3811 0666;
3812
3813 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3814 };
3815
3816 cf::cleanup "db_env_open(db): $@" if $@;
3817 };
3818 }
3819
3820 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3821 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3822 };
3823 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3824 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3825 };
3826 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3827 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3828 };
3829}
3830
3831{
3832 # configure IO::AIO
3833
3834 IO::AIO::min_parallel 8;
3835 IO::AIO::max_poll_time $TICK * 0.1;
3836 undef $AnyEvent::AIO::WATCHER;
3837}
3838
3839my $_log_backtrace;
3840
3841sub _log_backtrace {
3842 my ($msg, @addr) = @_;
3843
3844 $msg =~ s/\n//;
3845
3846 # limit the # of concurrent backtraces
3847 if ($_log_backtrace < 2) {
3848 ++$_log_backtrace;
3849 my $perl_bt = Carp::longmess $msg;
3850 async {
3851 $Coro::current->{desc} = "abt $msg";
3852
3853 my @bt = fork_call {
3854 @addr = map { sprintf "%x", $_ } @addr;
3855 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3856 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3857 or die "addr2line: $!";
3858
3859 my @funcs;
3860 my @res = <$fh>;
3861 chomp for @res;
3862 while (@res) {
3863 my ($func, $line) = splice @res, 0, 2, ();
3864 push @funcs, "[$func] $line";
3865 }
3866
3867 @funcs
3868 };
3869
3870 LOG llevInfo, "[ABT] $perl_bt\n";
3871 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3872 LOG llevInfo, "[ABT] $_\n" for @bt;
3873 --$_log_backtrace;
3874 };
3875 } else {
3876 LOG llevInfo, "[ABT] $msg\n";
3877 LOG llevInfo, "[ABT] [suppressed]\n";
3878 }
3879}
3880
3881# load additional modules
3882use cf::pod;
2202 3883
2203END { cf::emergency_save } 3884END { cf::emergency_save }
2204 3885
22051 38861
2206 3887

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines