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.384 by root, Fri Oct 12 18:17:16 2007 UTC vs.
Revision 1.446 by root, Tue Sep 16 16:03:02 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 Socket; 30use Socket;
9use Storable; 31use EV;
10use Event;
11use Opcode; 32use Opcode;
12use Safe; 33use Safe;
13use Safe::Hole; 34use Safe::Hole;
35use Storable ();
14 36
15use Coro 4.1 (); 37use Coro ();
16use Coro::State; 38use Coro::State;
17use Coro::Handle; 39use Coro::Handle;
40use Coro::EV;
18use Coro::Event; 41use Coro::AnyEvent;
19use Coro::Timer; 42use Coro::Timer;
20use Coro::Signal; 43use Coro::Signal;
21use Coro::Semaphore; 44use Coro::Semaphore;
45use Coro::AnyEvent;
22use Coro::AIO; 46use Coro::AIO;
47use Coro::BDB 1.6;
23use Coro::Storable; 48use Coro::Storable;
24use Coro::Util (); 49use Coro::Util ();
25 50
26use JSON::XS (); 51use JSON::XS 2.01 ();
27use BDB (); 52use BDB ();
28use Data::Dumper; 53use Data::Dumper;
29use Digest::MD5; 54use Digest::MD5;
30use Fcntl; 55use Fcntl;
31use YAML::Syck (); 56use YAML ();
32use IO::AIO 2.51 (); 57use IO::AIO ();
33use Time::HiRes; 58use Time::HiRes;
34use Compress::LZF; 59use Compress::LZF;
35use Digest::MD5 (); 60use Digest::MD5 ();
61
62AnyEvent::detect;
36 63
37# configure various modules to our taste 64# configure various modules to our taste
38# 65#
39$Storable::canonical = 1; # reduce rsync transfers 66$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 67Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 68Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
42 69
43$Event::Eval = 1; # no idea why this is required, but it is
44
45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46$YAML::Syck::ImplicitUnicode = 1;
47
48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 70$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
49 71
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 72sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51 73
52our %COMMAND = (); 74our %COMMAND = ();
59our %EXT_MAP = (); # pluggable maps 81our %EXT_MAP = (); # pluggable maps
60 82
61our $RELOAD; # number of reloads so far 83our $RELOAD; # number of reloads so far
62our @EVENT; 84our @EVENT;
63 85
64our $CONFDIR = confdir; 86our $CONFDIR = confdir;
65our $DATADIR = datadir; 87our $DATADIR = datadir;
66our $LIBDIR = "$DATADIR/ext"; 88our $LIBDIR = "$DATADIR/ext";
67our $PODDIR = "$DATADIR/pod"; 89our $PODDIR = "$DATADIR/pod";
68our $MAPDIR = "$DATADIR/" . mapdir; 90our $MAPDIR = "$DATADIR/" . mapdir;
69our $LOCALDIR = localdir; 91our $LOCALDIR = localdir;
70our $TMPDIR = "$LOCALDIR/" . tmpdir; 92our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 93our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir; 94our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random"; 95our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db"; 96our $BDBDIR = "$LOCALDIR/db";
97our $PIDFILE = "$LOCALDIR/pid";
98our $RUNTIMEFILE = "$LOCALDIR/runtime";
99
100our %RESOURCE;
75 101
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 102our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
77our $TICK_WATCHER;
78our $AIO_POLL_WATCHER;
79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 103our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
80our $NEXT_TICK; 104our $NEXT_TICK;
81our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off 105our $USE_FSYNC = 1; # use fsync to write maps - default off
83 106
84our $BDB_POLL_WATCHER;
85our $BDB_DEADLOCK_WATCHER; 107our $BDB_DEADLOCK_WATCHER;
86our $BDB_CHECKPOINT_WATCHER; 108our $BDB_CHECKPOINT_WATCHER;
87our $BDB_TRICKLE_WATCHER; 109our $BDB_TRICKLE_WATCHER;
88our $DB_ENV; 110our $DB_ENV;
89 111
90our %CFG; 112our %CFG;
91 113
92our $UPTIME; $UPTIME ||= time; 114our $UPTIME; $UPTIME ||= time;
93our $RUNTIME; 115our $RUNTIME;
116our $NOW;
94 117
95our (%PLAYER, %PLAYER_LOADING); # all users 118our (%PLAYER, %PLAYER_LOADING); # all users
96our (%MAP, %MAP_LOADING ); # all maps 119our (%MAP, %MAP_LOADING ); # all maps
97our $LINK_MAP; # the special {link} map, which is always available 120our $LINK_MAP; # the special {link} map, which is always available
98 121
99# used to convert map paths into valid unix filenames by replacing / by ∕ 122# used to convert map paths into valid unix filenames by replacing / by ∕
100our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 123our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
101 124
102our $LOAD; # a number between 0 (idle) and 1 (too many objects) 125our $LOAD; # a number between 0 (idle) and 1 (too many objects)
103our $LOADAVG; # same thing, but with alpha-smoothing 126our $LOADAVG; # same thing, but with alpha-smoothing
127our $JITTER; # average jitter
104our $tick_start; # for load detecting purposes 128our $TICK_START; # for load detecting purposes
105 129
106binmode STDOUT; 130binmode STDOUT;
107binmode STDERR; 131binmode STDERR;
108 132
109# read virtual server time, if available 133# read virtual server time, if available
110unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 134unless ($RUNTIME || !-e $RUNTIMEFILE) {
111 open my $fh, "<", "$LOCALDIR/runtime" 135 open my $fh, "<", $RUNTIMEFILE
112 or die "unable to read runtime file: $!"; 136 or die "unable to read $RUNTIMEFILE file: $!";
113 $RUNTIME = <$fh> + 0.; 137 $RUNTIME = <$fh> + 0.;
114} 138}
115 139
116mkdir $_ 140mkdir $_
117 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 141 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
162 186
163The raw value load value from the last tick. 187The raw value load value from the last tick.
164 188
165=item %cf::CFG 189=item %cf::CFG
166 190
167Configuration for the server, loaded from C</etc/crossfire/config>, or 191Configuration for the server, loaded from C</etc/deliantra-server/config>, or
168from wherever your confdir points to. 192from wherever your confdir points to.
169 193
170=item cf::wait_for_tick, cf::wait_for_tick_begin 194=item cf::wait_for_tick, cf::wait_for_tick_begin
171 195
172These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 196These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
193 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 217 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
194 218
195 LOG llevError, $msg; 219 LOG llevError, $msg;
196 }; 220 };
197} 221}
222
223$Coro::State::DIEHOOK = sub {
224 return unless $^S eq 0; # "eq", not "=="
225
226 if ($Coro::current == $Coro::main) {#d#
227 warn "DIEHOOK called in main context, Coro bug?\n";#d#
228 return;#d#
229 }#d#
230
231 # kill coroutine otherwise
232 warn Carp::longmess $_[0];
233 Coro::terminate
234};
235
236$SIG{__DIE__} = sub { }; #d#?
198 237
199@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 238@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
200@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 239@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
201@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 240@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
202@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 241@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
209for my $pkg (qw( 248for my $pkg (qw(
210 cf::global cf::attachable 249 cf::global cf::attachable
211 cf::object cf::object::player 250 cf::object cf::object::player
212 cf::client cf::player 251 cf::client cf::player
213 cf::arch cf::living 252 cf::arch cf::living
253 cf::map cf::mapspace
214 cf::map cf::party cf::region 254 cf::party cf::region
215)) { 255)) {
216 no strict 'refs';
217 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 256 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
218} 257}
219 258
220$Event::DIED = sub { 259$EV::DIED = sub {
221 warn "error in event callback: @_"; 260 warn "error in event callback: @_";
222}; 261};
223 262
224############################################################################# 263#############################################################################
225 264
248 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 287 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
249 $d 288 $d
250 } || "[unable to dump $_[0]: '$@']"; 289 } || "[unable to dump $_[0]: '$@']";
251} 290}
252 291
253=item $ref = cf::from_json $json 292=item $ref = cf::decode_json $json
254 293
255Converts a JSON string into the corresponding perl data structure. 294Converts a JSON string into the corresponding perl data structure.
256 295
257=item $json = cf::to_json $ref 296=item $json = cf::encode_json $ref
258 297
259Converts a perl data structure into its JSON representation. 298Converts a perl data structure into its JSON representation.
260 299
261=cut 300=cut
262 301
263our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 302our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
264 303
265sub to_json ($) { $json_coder->encode ($_[0]) } 304sub encode_json($) { $json_coder->encode ($_[0]) }
266sub from_json ($) { $json_coder->decode ($_[0]) } 305sub decode_json($) { $json_coder->decode ($_[0]) }
267 306
268=item cf::lock_wait $string 307=item cf::lock_wait $string
269 308
270Wait until the given lock is available. See cf::lock_acquire. 309Wait until the given lock is available. See cf::lock_acquire.
271 310
327 366
328 ! ! $LOCK{$key} 367 ! ! $LOCK{$key}
329} 368}
330 369
331sub freeze_mainloop { 370sub freeze_mainloop {
332 return unless $TICK_WATCHER->is_active; 371 tick_inhibit_inc;
333 372
334 my $guard = Coro::guard { 373 Coro::guard \&tick_inhibit_dec;
335 $TICK_WATCHER->start; 374}
336 }; 375
337 $TICK_WATCHER->stop; 376=item cf::periodic $interval, $cb
338 $guard 377
378Like EV::periodic, but randomly selects a starting point so that the actions
379get spread over timer.
380
381=cut
382
383sub periodic($$) {
384 my ($interval, $cb) = @_;
385
386 my $start = rand List::Util::min 180, $interval;
387
388 EV::periodic $start, $interval, 0, $cb
339} 389}
340 390
341=item cf::get_slot $time[, $priority[, $name]] 391=item cf::get_slot $time[, $priority[, $name]]
342 392
343Allocate $time seconds of blocking CPU time at priority C<$priority>: 393Allocate $time seconds of blocking CPU time at priority C<$priority>:
383 } 433 }
384 } 434 }
385}; 435};
386 436
387sub get_slot($;$$) { 437sub get_slot($;$$) {
438 return if tick_inhibit || $Coro::current == $Coro::main;
439
388 my ($time, $pri, $name) = @_; 440 my ($time, $pri, $name) = @_;
389 441
390 $time = $TICK * .6 if $time > $TICK * .6; 442 $time = $TICK * .6 if $time > $TICK * .6;
391 my $sig = new Coro::Signal; 443 my $sig = new Coro::Signal;
392 444
406 458
407BEGIN { *async = \&Coro::async_pool } 459BEGIN { *async = \&Coro::async_pool }
408 460
409=item cf::sync_job { BLOCK } 461=item cf::sync_job { BLOCK }
410 462
411The design of Crossfire TRT requires that the main coroutine ($Coro::main) 463The design of Deliantra requires that the main coroutine ($Coro::main)
412is always able to handle events or runnable, as Crossfire TRT is only 464is always able to handle events or runnable, as Deliantra is only
413partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 465partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
414acceptable. 466acceptable.
415 467
416If it must be done, put the blocking parts into C<sync_job>. This will run 468If it must be done, put the blocking parts into C<sync_job>. This will run
417the given BLOCK in another coroutine while waiting for the result. The 469the given BLOCK in another coroutine while waiting for the result. The
422 474
423sub sync_job(&) { 475sub sync_job(&) {
424 my ($job) = @_; 476 my ($job) = @_;
425 477
426 if ($Coro::current == $Coro::main) { 478 if ($Coro::current == $Coro::main) {
427 my $time = Event::time; 479 my $time = EV::time;
428 480
429 # this is the main coro, too bad, we have to block 481 # this is the main coro, too bad, we have to block
430 # till the operation succeeds, freezing the server :/ 482 # till the operation succeeds, freezing the server :/
431 483
432 LOG llevError | logBacktrace, Carp::longmess "sync job";#d# 484 LOG llevError, Carp::longmess "sync job";#d#
433 485
434 # TODO: use suspend/resume instead
435 # (but this is cancel-safe)
436 my $freeze_guard = freeze_mainloop; 486 my $freeze_guard = freeze_mainloop;
437 487
438 my $busy = 1; 488 my $busy = 1;
439 my @res; 489 my @res;
440 490
444 warn $@ if $@; 494 warn $@ if $@;
445 undef $busy; 495 undef $busy;
446 })->prio (Coro::PRIO_MAX); 496 })->prio (Coro::PRIO_MAX);
447 497
448 while ($busy) { 498 while ($busy) {
449 Coro::cede or Event::one_event; 499 if (Coro::nready) {
500 Coro::cede_notself;
501 } else {
502 EV::loop EV::LOOP_ONESHOT;
450 } 503 }
504 }
451 505
452 $time = Event::time - $time; 506 my $time = EV::time - $time;
453 507
454 LOG llevError | logBacktrace, Carp::longmess "long sync job"
455 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
456
457 $tick_start += $time; # do not account sync jobs to server load 508 $TICK_START += $time; # do not account sync jobs to server load
458 509
459 wantarray ? @res : $res[0] 510 wantarray ? @res : $res[0]
460 } else { 511 } else {
461 # we are in another coroutine, how wonderful, everything just works 512 # we are in another coroutine, how wonderful, everything just works
462 513
487=item fork_call { }, $args 538=item fork_call { }, $args
488 539
489Executes the given code block with the given arguments in a seperate 540Executes the given code block with the given arguments in a seperate
490process, returning the results. Everything must be serialisable with 541process, returning the results. Everything must be serialisable with
491Coro::Storable. May, of course, block. Note that the executed sub may 542Coro::Storable. May, of course, block. Note that the executed sub may
492never block itself or use any form of Event handling. 543never block itself or use any form of event handling.
493 544
494=cut 545=cut
495 546
496sub fork_call(&@) { 547sub fork_call(&@) {
497 my ($cb, @args) = @_; 548 my ($cb, @args) = @_;
504 reset_signals; 555 reset_signals;
505 &$cb 556 &$cb
506 }, @args; 557 }, @args;
507 558
508 wantarray ? @res : $res[-1] 559 wantarray ? @res : $res[-1]
560}
561
562=item $coin = coin_from_name $name
563
564=cut
565
566our %coin_alias = (
567 "silver" => "silvercoin",
568 "silvercoin" => "silvercoin",
569 "silvercoins" => "silvercoin",
570 "gold" => "goldcoin",
571 "goldcoin" => "goldcoin",
572 "goldcoins" => "goldcoin",
573 "platinum" => "platinacoin",
574 "platinumcoin" => "platinacoin",
575 "platinumcoins" => "platinacoin",
576 "platina" => "platinacoin",
577 "platinacoin" => "platinacoin",
578 "platinacoins" => "platinacoin",
579 "royalty" => "royalty",
580 "royalties" => "royalty",
581);
582
583sub coin_from_name($) {
584 $coin_alias{$_[0]}
585 ? cf::arch::find $coin_alias{$_[0]}
586 : undef
509} 587}
510 588
511=item $value = cf::db_get $family => $key 589=item $value = cf::db_get $family => $key
512 590
513Returns a single value from the environment database. 591Returns a single value from the environment database.
658attach callbacks/event handlers (a collection of which is called an "attachment") 736attach callbacks/event handlers (a collection of which is called an "attachment")
659to it. All such attachable objects support the following methods. 737to it. All such attachable objects support the following methods.
660 738
661In the following description, CLASS can be any of C<global>, C<object> 739In the following description, CLASS can be any of C<global>, C<object>
662C<player>, C<client> or C<map> (i.e. the attachable objects in 740C<player>, C<client> or C<map> (i.e. the attachable objects in
663Crossfire TRT). 741Deliantra).
664 742
665=over 4 743=over 4
666 744
667=item $attachable->attach ($attachment, key => $value...) 745=item $attachable->attach ($attachment, key => $value...)
668 746
950 } 1028 }
951 1029
952 0 1030 0
953} 1031}
954 1032
955=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1033=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
956 1034
957=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1035=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
958 1036
959Generate an object-specific event with the given arguments. 1037Generate an object-specific event with the given arguments.
960 1038
966 1044
967=cut 1045=cut
968 1046
969############################################################################# 1047#############################################################################
970# object support 1048# object support
971#
972 1049
1050sub _object_equal($$);
1051sub _object_equal($$) {
1052 my ($a, $b) = @_;
1053
1054 return 0 unless (ref $a) eq (ref $b);
1055
1056 if ("HASH" eq ref $a) {
1057 my @ka = keys %$a;
1058 my @kb = keys %$b;
1059
1060 return 0 if @ka != @kb;
1061
1062 for (0 .. $#ka) {
1063 return 0 unless $ka[$_] eq $kb[$_];
1064 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1065 }
1066
1067 } elsif ("ARRAY" eq ref $a) {
1068
1069 return 0 if @$a != @$b;
1070
1071 for (0 .. $#$a) {
1072 return 0 unless _object_equal $a->[$_], $b->[$_];
1073 }
1074
1075 } elsif ($a ne $b) {
1076 return 0;
1077 }
1078
1079 1
1080}
1081
1082our $SLOW_MERGES;#d#
973sub _can_merge { 1083sub _can_merge {
974 my ($ob1, $ob2) = @_; 1084 my ($ob1, $ob2) = @_;
975 1085
976 local $Storable::canonical = 1; 1086 ++$SLOW_MERGES;#d#
977 my $fob1 = Storable::freeze $ob1;
978 my $fob2 = Storable::freeze $ob2;
979 1087
980 $fob1 eq $fob2 1088 # we do the slow way here
1089 return _object_equal $ob1, $ob2
981} 1090}
982 1091
983sub reattach { 1092sub reattach {
984 # basically do the same as instantiate, without calling instantiate 1093 # basically do the same as instantiate, without calling instantiate
985 my ($obj) = @_; 1094 my ($obj) = @_;
986 1095
1096 # no longer needed after getting rid of delete_package?
987 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1097 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
988 1098
989 my $registry = $obj->registry; 1099 my $registry = $obj->registry;
990 1100
991 @$registry = (); 1101 @$registry = ();
992 1102
1007cf::attachable->attach ( 1117cf::attachable->attach (
1008 prio => -1000000, 1118 prio => -1000000,
1009 on_instantiate => sub { 1119 on_instantiate => sub {
1010 my ($obj, $data) = @_; 1120 my ($obj, $data) = @_;
1011 1121
1012 $data = from_json $data; 1122 $data = decode_json $data;
1013 1123
1014 for (@$data) { 1124 for (@$data) {
1015 my ($name, $args) = @$_; 1125 my ($name, $args) = @$_;
1016 1126
1017 $obj->attach ($name, %{$args || {} }); 1127 $obj->attach ($name, %{$args || {} });
1038 utf8::decode (my $decname = $filename); 1148 utf8::decode (my $decname = $filename);
1039 warn sprintf "saving %s (%d,%d)\n", 1149 warn sprintf "saving %s (%d,%d)\n",
1040 $decname, length $$rdata, scalar @$objs; 1150 $decname, length $$rdata, scalar @$objs;
1041 1151
1042 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1152 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1043 chmod SAVE_MODE, $fh; 1153 aio_chmod $fh, SAVE_MODE;
1044 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1154 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1045 aio_fsync $fh if $cf::USE_FSYNC; 1155 aio_fsync $fh if $cf::USE_FSYNC;
1046 close $fh; 1156 aio_close $fh;
1047 1157
1048 if (@$objs) { 1158 if (@$objs) {
1049 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1159 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1050 chmod SAVE_MODE, $fh; 1160 aio_chmod $fh, SAVE_MODE;
1051 my $data = Coro::Storable::blocking_nfreeze { version => 1, objs => $objs }; 1161 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1052 aio_write $fh, 0, (length $data), $data, 0; 1162 aio_write $fh, 0, (length $data), $data, 0;
1053 aio_fsync $fh if $cf::USE_FSYNC; 1163 aio_fsync $fh if $cf::USE_FSYNC;
1054 close $fh; 1164 aio_close $fh;
1055 aio_rename "$filename.pst~", "$filename.pst"; 1165 aio_rename "$filename.pst~", "$filename.pst";
1056 } 1166 }
1057 } else { 1167 } else {
1058 aio_unlink "$filename.pst"; 1168 aio_unlink "$filename.pst";
1059 } 1169 }
1087 1197
1088 unless (aio_stat "$filename.pst") { 1198 unless (aio_stat "$filename.pst") {
1089 (aio_load "$filename.pst", $av) >= 0 1199 (aio_load "$filename.pst", $av) >= 0
1090 or return; 1200 or return;
1091 1201
1092 my $st = eval { Coro::Storable::thaw $av } 1202 my $st = eval { Coro::Storable::thaw $av };
1093 || eval { my $guard = Coro::Storable::guard; Storable::thaw $av }; #d# compatibility, remove
1094 $av = $st->{objs}; 1203 $av = $st->{objs};
1095 } 1204 }
1096 1205
1097 utf8::decode (my $decname = $filename); 1206 utf8::decode (my $decname = $filename);
1098 warn sprintf "loading %s (%d,%d)\n", 1207 warn sprintf "loading %s (%d,%d)\n",
1229 1338
1230 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1339 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1231 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1340 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1232 1341
1233 $ext{source} = 1342 $ext{source} =
1234 "package $pkg; use strict; use utf8;\n" 1343 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1235 . "#line 1 \"$path\"\n{\n" 1344 . "#line 1 \"$path\"\n{\n"
1236 . $source 1345 . $source
1237 . "\n};\n1"; 1346 . "\n};\n1";
1238 1347
1239 $todo{$base} = \%ext; 1348 $todo{$base} = \%ext;
1255 my $msg = $@ ? "$v->{path}: $@\n" 1364 my $msg = $@ ? "$v->{path}: $@\n"
1256 : "$v->{base}: extension inactive.\n"; 1365 : "$v->{base}: extension inactive.\n";
1257 1366
1258 if (exists $v->{meta}{mandatory}) { 1367 if (exists $v->{meta}{mandatory}) {
1259 warn $msg; 1368 warn $msg;
1260 warn "mandatory extension failed to load, exiting.\n"; 1369 cf::cleanup "mandatory extension failed to load, exiting.";
1261 exit 1;
1262 } 1370 }
1263 1371
1264 warn $msg; 1372 warn $msg;
1265 } 1373 }
1266 1374
1355 my $f = new_from_file cf::object::thawer path $login 1463 my $f = new_from_file cf::object::thawer path $login
1356 or return; 1464 or return;
1357 1465
1358 my $pl = cf::player::load_pl $f 1466 my $pl = cf::player::load_pl $f
1359 or return; 1467 or return;
1468
1360 local $cf::PLAYER_LOADING{$login} = $pl; 1469 local $cf::PLAYER_LOADING{$login} = $pl;
1361 $f->resolve_delayed_derefs; 1470 $f->resolve_delayed_derefs;
1362 $cf::PLAYER{$login} = $pl 1471 $cf::PLAYER{$login} = $pl
1363 } 1472 }
1364 } 1473 }
1374 1483
1375 return if $pl->{deny_save}; 1484 return if $pl->{deny_save};
1376 1485
1377 aio_mkdir playerdir $pl, 0770; 1486 aio_mkdir playerdir $pl, 0770;
1378 $pl->{last_save} = $cf::RUNTIME; 1487 $pl->{last_save} = $cf::RUNTIME;
1488
1489 cf::get_slot 0.01;
1379 1490
1380 $pl->save_pl ($path); 1491 $pl->save_pl ($path);
1381 cf::cede_to_tick; 1492 cf::cede_to_tick;
1382} 1493}
1383 1494
1415 my ($pl) = @_; 1526 my ($pl) = @_;
1416 1527
1417 my $name = $pl->ob->name; 1528 my $name = $pl->ob->name;
1418 1529
1419 $pl->{deny_save} = 1; 1530 $pl->{deny_save} = 1;
1420 $pl->password ("*"); # this should lock out the player until we nuked the dir 1531 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1421 1532
1422 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1533 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1423 $pl->deactivate; 1534 $pl->deactivate;
1535 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1536 $pl->ob->check_score;
1424 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1537 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1425 $pl->ns->destroy if $pl->ns; 1538 $pl->ns->destroy if $pl->ns;
1426 1539
1427 my $path = playerdir $pl; 1540 my $path = playerdir $pl;
1428 my $temp = "$path~$cf::RUNTIME~deleting~"; 1541 my $temp = "$path~$cf::RUNTIME~deleting~";
1467 1580
1468 for my $login (@$dirs) { 1581 for my $login (@$dirs) {
1469 my $path = path $login; 1582 my $path = path $login;
1470 1583
1471 # a .pst is a dead give-away for a valid player 1584 # a .pst is a dead give-away for a valid player
1472 unless (-e "$path.pst") { 1585 # if no pst file found, open and chekc for blocked users
1586 if (aio_stat "$path.pst") {
1473 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next; 1587 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1474 aio_read $fh, 0, 512, my $buf, 0 or next; 1588 aio_read $fh, 0, 512, my $buf, 0 or next;
1475 $buf !~ /^password -------------$/m or next; # official not-valid tag 1589 $buf !~ /^password -------------$/m or next; # official not-valid tag
1476 } 1590 }
1477 1591
1512 1626
1513=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1627=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1514 1628
1515Expand crossfire pod fragments into protocol xml. 1629Expand crossfire pod fragments into protocol xml.
1516 1630
1517=cut
1518
1519sub expand_cfpod {
1520 ((my $self), (local $_)) = @_;
1521
1522 # escape & and <
1523 s/&/&amp;/g;
1524 s/(?<![BIUGHT])</&lt;/g;
1525
1526 # this is buggy, it needs to properly take care of nested <'s
1527
1528 1 while
1529 # replace B<>, I<>, U<> etc.
1530 s/B<([^\>]*)>/<b>$1<\/b>/
1531 || s/I<([^\>]*)>/<i>$1<\/i>/
1532 || s/U<([^\>]*)>/<u>$1<\/u>/
1533 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1534 # replace G<male|female> tags
1535 || s{G<([^>|]*)\|([^>]*)>}{
1536 $self->gender ? $2 : $1
1537 }ge
1538 # replace H<hint text>
1539 || s{H<([^\>]*)>}
1540 {
1541 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1542 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1543 "")
1544 [$self->{hintmode}]
1545 }ge;
1546
1547 # create single paragraphs (very hackish)
1548 s/(?<=\S)\n(?=\w)/ /g;
1549
1550 # compress some whitespace
1551 s/\s+\n/\n/g; # ws line-ends
1552 s/\n\n+/\n/g; # double lines
1553 s/^\n+//; # beginning lines
1554 s/\n+$//; # ending lines
1555
1556 $_
1557}
1558
1559sub hintmode {
1560 $_[0]{hintmode} = $_[1] if @_ > 1;
1561 $_[0]{hintmode}
1562}
1563
1564=item $player->ext_reply ($msgid, @msg) 1631=item $player->ext_reply ($msgid, @msg)
1565 1632
1566Sends an ext reply to the player. 1633Sends an ext reply to the player.
1567 1634
1568=cut 1635=cut
1634our $MAX_RESET = 3600; 1701our $MAX_RESET = 3600;
1635our $DEFAULT_RESET = 3000; 1702our $DEFAULT_RESET = 3000;
1636 1703
1637sub generate_random_map { 1704sub generate_random_map {
1638 my ($self, $rmp) = @_; 1705 my ($self, $rmp) = @_;
1706
1707 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1708
1639 # mit "rum" bekleckern, nicht 1709 # mit "rum" bekleckern, nicht
1640 $self->_create_random_map ( 1710 $self->_create_random_map (
1641 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1711 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1642 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1712 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1643 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1713 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1765 1835
1766# the temporary/swap location 1836# the temporary/swap location
1767sub save_path { 1837sub save_path {
1768 my ($self) = @_; 1838 my ($self) = @_;
1769 1839
1770 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1840 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1771 "$TMPDIR/$path.map" 1841 "$TMPDIR/$path.map"
1772} 1842}
1773 1843
1774# the unique path, undef == no special unique path 1844# the unique path, undef == no special unique path
1775sub uniq_path { 1845sub uniq_path {
1776 my ($self) = @_; 1846 my ($self) = @_;
1777 1847
1778 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1848 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1779 "$UNIQUEDIR/$path" 1849 "$UNIQUEDIR/$path"
1780} 1850}
1781 1851
1782# and all this just because we cannot iterate over 1852# and all this just because we cannot iterate over
1783# all maps in C++... 1853# all maps in C++...
1881 1951
1882 cf::lock_wait "map_data:$path";#d#remove 1952 cf::lock_wait "map_data:$path";#d#remove
1883 cf::lock_wait "map_find:$path"; 1953 cf::lock_wait "map_find:$path";
1884 1954
1885 $cf::MAP{$path} || do { 1955 $cf::MAP{$path} || do {
1886 my $guard1 = cf::lock_acquire "map_find:$path";
1887 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it 1956 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1957 my $guard2 = cf::lock_acquire "map_find:$path";
1888 1958
1889 my $map = new_from_path cf::map $path 1959 my $map = new_from_path cf::map $path
1890 or return; 1960 or return;
1891 1961
1892 $map->{last_save} = $cf::RUNTIME; 1962 $map->{last_save} = $cf::RUNTIME;
1895 or return; 1965 or return;
1896 1966
1897 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1967 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1898 # doing this can freeze the server in a sync job, obviously 1968 # doing this can freeze the server in a sync job, obviously
1899 #$cf::WAIT_FOR_TICK->wait; 1969 #$cf::WAIT_FOR_TICK->wait;
1970 undef $guard2;
1900 undef $guard1; 1971 undef $guard1;
1901 undef $guard2;
1902 $map->reset; 1972 $map->reset;
1903 return find $path; 1973 return find $path;
1904 } 1974 }
1905 1975
1906 $cf::MAP{$path} = $map 1976 $cf::MAP{$path} = $map
1933 my $f = new_from_file cf::object::thawer $self->{load_path}; 2003 my $f = new_from_file cf::object::thawer $self->{load_path};
1934 $f->skip_block; 2004 $f->skip_block;
1935 $self->_load_objects ($f) 2005 $self->_load_objects ($f)
1936 or return; 2006 or return;
1937 2007
1938 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2008 $self->post_load_original
1939 if delete $self->{load_original}; 2009 if delete $self->{load_original};
1940 2010
1941 if (my $uniq = $self->uniq_path) { 2011 if (my $uniq = $self->uniq_path) {
1942 utf8::encode $uniq; 2012 utf8::encode $uniq;
1943 unless (aio_stat $uniq) { 2013 unless (aio_stat $uniq) {
1969 } 2039 }
1970 2040
1971 $self->{last_save} = $cf::RUNTIME; 2041 $self->{last_save} = $cf::RUNTIME;
1972 $self->last_access ($cf::RUNTIME); 2042 $self->last_access ($cf::RUNTIME);
1973 2043
1974 $self->in_memory (cf::MAP_IN_MEMORY); 2044 $self->in_memory (cf::MAP_ACTIVE);
1975 } 2045 }
1976 2046
1977 $self->post_load; 2047 $self->post_load;
1978} 2048}
1979 2049
2037 my ($path, $origin, $load) = @_; 2107 my ($path, $origin, $load) = @_;
2038 2108
2039 $path = normalise $path, $origin && $origin->{path}; 2109 $path = normalise $path, $origin && $origin->{path};
2040 2110
2041 if (my $map = $cf::MAP{$path}) { 2111 if (my $map = $cf::MAP{$path}) {
2042 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY; 2112 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2043 } 2113 }
2044 2114
2045 $MAP_PREFETCH{$path} |= $load; 2115 $MAP_PREFETCH{$path} |= $load;
2046 2116
2047 $MAP_PREFETCHER ||= cf::async { 2117 $MAP_PREFETCHER ||= cf::async {
2084 cf::async { 2154 cf::async {
2085 $Coro::current->{desc} = "map player save"; 2155 $Coro::current->{desc} = "map player save";
2086 $_->contr->save for $self->players; 2156 $_->contr->save for $self->players;
2087 }; 2157 };
2088 2158
2159 cf::get_slot 0.02;
2160
2089 if ($uniq) { 2161 if ($uniq) {
2090 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2162 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2091 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2163 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2092 } else { 2164 } else {
2093 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2165 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2101 $self->save; 2173 $self->save;
2102 2174
2103 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2175 my $lock = cf::lock_acquire "map_data:$self->{path}";
2104 2176
2105 return if $self->players; 2177 return if $self->players;
2106 return if $self->in_memory != cf::MAP_IN_MEMORY; 2178 return if $self->in_memory != cf::MAP_ACTIVE;
2107 return if $self->{deny_save}; 2179 return if $self->{deny_save};
2108 2180
2109 $self->in_memory (cf::MAP_SWAPPED); 2181 $self->in_memory (cf::MAP_SWAPPED);
2110 2182
2111 $self->deactivate; 2183 $self->deactivate;
2229 2301
2230sub unique_maps() { 2302sub unique_maps() {
2231 [ 2303 [
2232 map { 2304 map {
2233 utf8::decode $_; 2305 utf8::decode $_;
2234 /\.map$/ 2306 s/\.map$//; # TODO future compatibility hack
2307 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2308 ? ()
2235 ? normalise $_ 2309 : normalise $_
2236 : ()
2237 } @{ aio_readdir $UNIQUEDIR or [] } 2310 } @{ aio_readdir $UNIQUEDIR or [] }
2238 ] 2311 ]
2239} 2312}
2240 2313
2241package cf;
2242
2243=back 2314=back
2244 2315
2245=head3 cf::object 2316=head3 cf::object
2246 2317
2247=cut 2318=cut
2250 2321
2251=over 4 2322=over 4
2252 2323
2253=item $ob->inv_recursive 2324=item $ob->inv_recursive
2254 2325
2255Returns the inventory of the object _and_ their inventories, recursively. 2326Returns the inventory of the object I<and> their inventories, recursively,
2327but I<not> the object itself.
2256 2328
2257=cut 2329=cut
2258 2330
2259sub inv_recursive_; 2331sub inv_recursive_;
2260sub inv_recursive_ { 2332sub inv_recursive_ {
2265 inv_recursive_ inv $_[0] 2337 inv_recursive_ inv $_[0]
2266} 2338}
2267 2339
2268=item $ref = $ob->ref 2340=item $ref = $ob->ref
2269 2341
2270creates and returns a persistent reference to an objetc that can be stored as a string. 2342Creates and returns a persistent reference to an object that can be stored as a string.
2271 2343
2272=item $ob = cf::object::deref ($refstring) 2344=item $ob = cf::object::deref ($refstring)
2273 2345
2274returns the objetc referenced by refstring. may return undef when it cnanot find the object, 2346returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2275even if the object actually exists. May block. 2347even if the object actually exists. May block.
2307can be C<undef>. Does the right thing when the player is currently in a 2379can be C<undef>. Does the right thing when the player is currently in a
2308dialogue with the given NPC character. 2380dialogue with the given NPC character.
2309 2381
2310=cut 2382=cut
2311 2383
2384our $SAY_CHANNEL = {
2385 id => "say",
2386 title => "Map",
2387 reply => "say ",
2388 tooltip => "Things said to and replied from npcs near you and other players on the same map only.",
2389};
2390
2391our $CHAT_CHANNEL = {
2392 id => "chat",
2393 title => "Chat",
2394 reply => "chat ",
2395 tooltip => "Player chat and shouts, global to the server.",
2396};
2397
2312# rough implementation of a future "reply" method that works 2398# rough implementation of a future "reply" method that works
2313# with dialog boxes. 2399# with dialog boxes.
2314#TODO: the first argument must go, split into a $npc->reply_to ( method 2400#TODO: the first argument must go, split into a $npc->reply_to ( method
2315sub cf::object::player::reply($$$;$) { 2401sub cf::object::player::reply($$$;$) {
2316 my ($self, $npc, $msg, $flags) = @_; 2402 my ($self, $npc, $msg, $flags) = @_;
2327 my $dialog = $pl->{npc_dialog}; 2413 my $dialog = $pl->{npc_dialog};
2328 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2414 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2329 2415
2330 } else { 2416 } else {
2331 $msg = $npc->name . " says: $msg" if $npc; 2417 $msg = $npc->name . " says: $msg" if $npc;
2332 $self->message ($msg, $flags); 2418 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2333 } 2419 }
2334 } 2420 }
2335} 2421}
2336 2422
2337=item $object->send_msg ($channel, $msg, $color, [extra...]) 2423=item $object->send_msg ($channel, $msg, $color, [extra...])
2362 2448
2363=item $player_object->enter_link 2449=item $player_object->enter_link
2364 2450
2365Freezes the player and moves him/her to a special map (C<{link}>). 2451Freezes the player and moves him/her to a special map (C<{link}>).
2366 2452
2367The player should be reasonably safe there for short amounts of time. You 2453The player should be reasonably safe there for short amounts of time (e.g.
2368I<MUST> call C<leave_link> as soon as possible, though. 2454for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2455though, as the palyer cannot control the character while it is on the link
2456map.
2369 2457
2370Will never block. 2458Will never block.
2371 2459
2372=item $player_object->leave_link ($map, $x, $y) 2460=item $player_object->leave_link ($map, $x, $y)
2373 2461
2431 2519
2432 $map->load; 2520 $map->load;
2433 $map->load_neighbours; 2521 $map->load_neighbours;
2434 2522
2435 return unless $self->contr->active; 2523 return unless $self->contr->active;
2524 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2436 $self->activate_recursive; 2525 $self->activate_recursive;
2437 2526
2438 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2527 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2439 $self->enter_map ($map, $x, $y); 2528 $self->enter_map ($map, $x, $y);
2440} 2529}
2444Moves the player to the given map-path and coordinates by first freezing 2533Moves the player to the given map-path and coordinates by first freezing
2445her, loading and preparing them map, calling the provided $check callback 2534her, loading and preparing them map, calling the provided $check callback
2446that has to return the map if sucecssful, and then unfreezes the player on 2535that has to return the map if sucecssful, and then unfreezes the player on
2447the new (success) or old (failed) map position. In either case, $done will 2536the new (success) or old (failed) map position. In either case, $done will
2448be called at the end of this process. 2537be called at the end of this process.
2538
2539Note that $check will be called with a potentially non-loaded map, so if
2540it needs a loaded map it has to call C<< ->load >>.
2449 2541
2450=cut 2542=cut
2451 2543
2452our $GOTOGEN; 2544our $GOTOGEN;
2453 2545
2532} 2624}
2533 2625
2534sub prepare_random_map { 2626sub prepare_random_map {
2535 my ($exit) = @_; 2627 my ($exit) = @_;
2536 2628
2537 my $guard = cf::lock_acquire "exit_prepare:$exit";
2538
2539 # all this does is basically replace the /! path by 2629 # all this does is basically replace the /! path by
2540 # a new random map path (?random/...) with a seed 2630 # a new random map path (?random/...) with a seed
2541 # that depends on the exit object 2631 # that depends on the exit object
2542 2632
2543 my $rmp = parse_random_map_params $exit->msg; 2633 my $rmp = parse_random_map_params $exit->msg;
2545 if ($exit->map) { 2635 if ($exit->map) {
2546 $rmp->{region} = $exit->region->name; 2636 $rmp->{region} = $exit->region->name;
2547 $rmp->{origin_map} = $exit->map->path; 2637 $rmp->{origin_map} = $exit->map->path;
2548 $rmp->{origin_x} = $exit->x; 2638 $rmp->{origin_x} = $exit->x;
2549 $rmp->{origin_y} = $exit->y; 2639 $rmp->{origin_y} = $exit->y;
2640
2641 $exit->map->touch;
2550 } 2642 }
2551 2643
2552 $rmp->{random_seed} ||= $exit->random_seed; 2644 $rmp->{random_seed} ||= $exit->random_seed;
2553 2645
2554 my $data = cf::to_json $rmp; 2646 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2555 my $md5 = Digest::MD5::md5_hex $data; 2647 my $md5 = Digest::MD5::md5_hex $data;
2556 my $meta = "$RANDOMDIR/$md5.meta"; 2648 my $meta = "$RANDOMDIR/$md5.meta";
2557 2649
2558 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2650 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2559 aio_write $fh, 0, (length $data), $data, 0; 2651 aio_write $fh, 0, (length $data), $data, 0;
2560 undef $fh; 2652 undef $fh;
2561 aio_rename "$meta~", $meta; 2653 aio_rename "$meta~", $meta;
2562 2654
2655 my $slaying = "?random/$md5";
2656
2657 if ($exit->valid) {
2563 $exit->slaying ("?random/$md5"); 2658 $exit->slaying ("?random/$md5");
2564 $exit->msg (undef); 2659 $exit->msg (undef);
2660 }
2565 } 2661 }
2566} 2662}
2567 2663
2568sub cf::object::player::enter_exit { 2664sub cf::object::player::enter_exit {
2569 my ($self, $exit) = @_; 2665 my ($self, $exit) = @_;
2570 2666
2571 return unless $self->type == cf::PLAYER; 2667 return unless $self->type == cf::PLAYER;
2572 2668
2573 if ($exit->slaying eq "/!") {
2574 #TODO: this should de-fi-ni-te-ly not be a sync-job
2575 # the problem is that $exit might not survive long enough
2576 # so it needs to be done right now, right here
2577 cf::sync_job { prepare_random_map $exit };
2578 }
2579
2580 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2581 my $hp = $exit->stats->hp;
2582 my $sp = $exit->stats->sp;
2583
2584 $self->enter_link; 2669 $self->enter_link;
2585 2670
2586 # if exit is damned, update players death & WoR home-position
2587 $self->contr->savebed ($slaying, $hp, $sp)
2588 if $exit->flag (FLAG_DAMNED);
2589
2590 (async { 2671 (async {
2591 $Coro::current->{desc} = "enter_exit $slaying $hp $sp"; 2672 $Coro::current->{desc} = "enter_exit";
2592 2673
2593 $self->deactivate_recursive; # just to be sure
2594 unless (eval { 2674 unless (eval {
2675 $self->deactivate_recursive; # just to be sure
2676
2677 # random map handling
2678 {
2679 my $guard = cf::lock_acquire "exit_prepare:$exit";
2680
2681 prepare_random_map $exit
2682 if $exit->slaying eq "/!";
2683 }
2684
2685 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2686 my $x = $exit->stats->hp;
2687 my $y = $exit->stats->sp;
2688
2595 $self->goto ($slaying, $hp, $sp); 2689 $self->goto ($map, $x, $y);
2596 2690
2691 # if exit is damned, update players death & WoR home-position
2692 $self->contr->savebed ($map, $x, $y)
2693 if $exit->flag (cf::FLAG_DAMNED);
2694
2597 1; 2695 1
2598 }) { 2696 }) {
2599 $self->message ("Something went wrong deep within the crossfire server. " 2697 $self->message ("Something went wrong deep within the crossfire server. "
2600 . "I'll try to bring you back to the map you were before. " 2698 . "I'll try to bring you back to the map you were before. "
2601 . "Please report this to the dungeon master!", 2699 . "Please report this to the dungeon master!",
2602 cf::NDI_UNIQUE | cf::NDI_RED); 2700 cf::NDI_UNIQUE | cf::NDI_RED);
2632the message, with C<log> being the default. If C<$color> is negative, suppress 2730the message, with C<log> being the default. If C<$color> is negative, suppress
2633the message unless the client supports the msg packet. 2731the message unless the client supports the msg packet.
2634 2732
2635=cut 2733=cut
2636 2734
2735# non-persistent channels (usually the info channel)
2637our %CHANNEL = ( 2736our %CHANNEL = (
2638 "c/identify" => { 2737 "c/identify" => {
2639 id => "infobox", 2738 id => "infobox",
2640 title => "Identify", 2739 title => "Identify",
2641 reply => undef, 2740 reply => undef,
2645 id => "infobox", 2744 id => "infobox",
2646 title => "Examine", 2745 title => "Examine",
2647 reply => undef, 2746 reply => undef,
2648 tooltip => "Signs and other items you examined", 2747 tooltip => "Signs and other items you examined",
2649 }, 2748 },
2749 "c/book" => {
2750 id => "infobox",
2751 title => "Book",
2752 reply => undef,
2753 tooltip => "The contents of a note or book",
2754 },
2650 "c/lookat" => { 2755 "c/lookat" => {
2651 id => "infobox", 2756 id => "infobox",
2652 title => "Look", 2757 title => "Look",
2653 reply => undef, 2758 reply => undef,
2654 tooltip => "What you saw there", 2759 tooltip => "What you saw there",
2655 }, 2760 },
2761 "c/who" => {
2762 id => "infobox",
2763 title => "Players",
2764 reply => undef,
2765 tooltip => "Shows players who are currently online",
2766 },
2767 "c/body" => {
2768 id => "infobox",
2769 title => "Body Parts",
2770 reply => undef,
2771 tooltip => "Shows which body parts you posess and are available",
2772 },
2773 "c/uptime" => {
2774 id => "infobox",
2775 title => "Uptime",
2776 reply => undef,
2777 tooltip => "How long the server has been running since last restart",
2778 },
2779 "c/mapinfo" => {
2780 id => "infobox",
2781 title => "Map Info",
2782 reply => undef,
2783 tooltip => "Information related to the maps",
2784 },
2785 "c/party" => {
2786 id => "party",
2787 title => "Party",
2788 reply => "gsay ",
2789 tooltip => "Messages and chat related to your party",
2790 },
2656); 2791);
2657 2792
2658sub cf::client::send_msg { 2793sub cf::client::send_msg {
2659 my ($self, $channel, $msg, $color, @extra) = @_; 2794 my ($self, $channel, $msg, $color, @extra) = @_;
2660 2795
2687 if ($self->can_msg) { 2822 if ($self->can_msg) {
2688 # default colour, mask it out 2823 # default colour, mask it out
2689 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2824 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2690 if $color & cf::NDI_DEF; 2825 if $color & cf::NDI_DEF;
2691 2826
2692 $self->send_packet ("msg " . $self->{json_coder}->encode ( 2827 my $pkt = "msg "
2828 . $self->{json_coder}->encode (
2693 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 2829 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2830 );
2831
2832 # try lzf for large packets
2833 $pkt = "lzf " . Compress::LZF::compress $pkt
2834 if 1024 <= length $pkt and $self->{can_lzf};
2835
2836 # split very large packets
2837 if (8192 < length $pkt and $self->{can_lzf}) {
2838 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2839 $pkt = "frag";
2840 }
2841
2842 $self->send_packet ($pkt);
2694 } else { 2843 } else {
2695 if ($color >= 0) { 2844 if ($color >= 0) {
2696 # replace some tags by gcfclient-compatible ones 2845 # replace some tags by gcfclient-compatible ones
2697 for ($msg) { 2846 for ($msg) {
2698 1 while 2847 1 while
2897 3046
2898The following functions and methods are available within a safe environment: 3047The following functions and methods are available within a safe environment:
2899 3048
2900 cf::object 3049 cf::object
2901 contr pay_amount pay_player map x y force_find force_add destroy 3050 contr pay_amount pay_player map x y force_find force_add destroy
2902 insert remove name archname title slaying race decrease_ob_nr 3051 insert remove name archname title slaying race decrease split
2903 3052
2904 cf::object::player 3053 cf::object::player
2905 player 3054 player
2906 3055
2907 cf::player 3056 cf::player
2912 3061
2913=cut 3062=cut
2914 3063
2915for ( 3064for (
2916 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3065 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2917 insert remove inv name archname title slaying race 3066 insert remove inv nrof name archname title slaying race
2918 decrease_ob_nr destroy)], 3067 decrease split destroy change_exp)],
2919 ["cf::object::player" => qw(player)], 3068 ["cf::object::player" => qw(player)],
2920 ["cf::player" => qw(peaceful)], 3069 ["cf::player" => qw(peaceful)],
2921 ["cf::map" => qw(trigger)], 3070 ["cf::map" => qw(trigger)],
2922) { 3071) {
2923 no strict 'refs'; 3072 no strict 'refs';
3028 { 3177 {
3029 my $faces = $facedata->{faceinfo}; 3178 my $faces = $facedata->{faceinfo};
3030 3179
3031 while (my ($face, $info) = each %$faces) { 3180 while (my ($face, $info) = each %$faces) {
3032 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3181 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3182
3033 cf::face::set_visibility $idx, $info->{visibility}; 3183 cf::face::set_visibility $idx, $info->{visibility};
3034 cf::face::set_magicmap $idx, $info->{magicmap}; 3184 cf::face::set_magicmap $idx, $info->{magicmap};
3035 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3185 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
3036 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3186 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3037 3187
3038 cf::cede_to_tick; 3188 cf::cede_to_tick;
3039 } 3189 }
3040 3190
3041 while (my ($face, $info) = each %$faces) { 3191 while (my ($face, $info) = each %$faces) {
3042 next unless $info->{smooth}; 3192 next unless $info->{smooth};
3193
3043 my $idx = cf::face::find $face 3194 my $idx = cf::face::find $face
3044 or next; 3195 or next;
3196
3045 if (my $smooth = cf::face::find $info->{smooth}) { 3197 if (my $smooth = cf::face::find $info->{smooth}) {
3046 cf::face::set_smooth $idx, $smooth; 3198 cf::face::set_smooth $idx, $smooth;
3047 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3199 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3048 } else { 3200 } else {
3049 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3201 warn "smooth face '$info->{smooth}' not found for face '$face'";
3067 { 3219 {
3068 # TODO: for gcfclient pleasure, we should give resources 3220 # TODO: for gcfclient pleasure, we should give resources
3069 # that gcfclient doesn't grok a >10000 face index. 3221 # that gcfclient doesn't grok a >10000 face index.
3070 my $res = $facedata->{resource}; 3222 my $res = $facedata->{resource};
3071 3223
3072 my $soundconf = delete $res->{"res/sound.conf"};
3073
3074 while (my ($name, $info) = each %$res) { 3224 while (my ($name, $info) = each %$res) {
3225 if (defined $info->{type}) {
3075 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3226 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3076 my $data; 3227 my $data;
3077 3228
3078 if ($info->{type} & 1) { 3229 if ($info->{type} & 1) {
3079 # prepend meta info 3230 # prepend meta info
3080 3231
3081 my $meta = $enc->encode ({ 3232 my $meta = $enc->encode ({
3082 name => $name, 3233 name => $name,
3083 %{ $info->{meta} || {} }, 3234 %{ $info->{meta} || {} },
3084 }); 3235 });
3085 3236
3086 $data = pack "(w/a*)*", $meta, $info->{data}; 3237 $data = pack "(w/a*)*", $meta, $info->{data};
3238 } else {
3239 $data = $info->{data};
3240 }
3241
3242 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3243 cf::face::set_type $idx, $info->{type};
3087 } else { 3244 } else {
3088 $data = $info->{data}; 3245 $RESOURCE{$name} = $info;
3089 } 3246 }
3090 3247
3091 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3092 cf::face::set_type $idx, $info->{type};
3093
3094 cf::cede_to_tick; 3248 cf::cede_to_tick;
3095 } 3249 }
3096
3097 if ($soundconf) {
3098 $soundconf = $enc->decode (delete $soundconf->{data});
3099
3100 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3101 my $sound = $soundconf->{compat}[$_]
3102 or next;
3103
3104 my $face = cf::face::find "sound/$sound->[1]";
3105 cf::sound::set $sound->[0] => $face;
3106 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3107 }
3108
3109 while (my ($k, $v) = each %{$soundconf->{event}}) {
3110 my $face = cf::face::find "sound/$v";
3111 cf::sound::set $k => $face;
3112 }
3113 }
3114 } 3250 }
3251
3252 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3115 3253
3116 1 3254 1
3117} 3255}
3256
3257cf::global->attach (on_resource_update => sub {
3258 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3259 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3260
3261 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3262 my $sound = $soundconf->{compat}[$_]
3263 or next;
3264
3265 my $face = cf::face::find "sound/$sound->[1]";
3266 cf::sound::set $sound->[0] => $face;
3267 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3268 }
3269
3270 while (my ($k, $v) = each %{$soundconf->{event}}) {
3271 my $face = cf::face::find "sound/$v";
3272 cf::sound::set $k => $face;
3273 }
3274 }
3275});
3118 3276
3119register_exticmd fx_want => sub { 3277register_exticmd fx_want => sub {
3120 my ($ns, $want) = @_; 3278 my ($ns, $want) = @_;
3121 3279
3122 while (my ($k, $v) = each %$want) { 3280 while (my ($k, $v) = each %$want) {
3123 $ns->fx_want ($k, $v); 3281 $ns->fx_want ($k, $v);
3124 } 3282 }
3125}; 3283};
3284
3285sub load_resource_file($) {
3286 my $guard = lock_acquire "load_resource_file";
3287
3288 my $status = load_resource_file_ $_[0];
3289 get_slot 0.1, 100;
3290 cf::arch::commit_load;
3291
3292 $status
3293}
3126 3294
3127sub reload_regions { 3295sub reload_regions {
3128 # HACK to clear player env face cache, we need some signal framework 3296 # HACK to clear player env face cache, we need some signal framework
3129 # for this (global event?) 3297 # for this (global event?)
3130 %ext::player_env::MUSIC_FACE_CACHE = (); 3298 %ext::player_env::MUSIC_FACE_CACHE = ();
3144} 3312}
3145 3313
3146sub reload_archetypes { 3314sub reload_archetypes {
3147 load_resource_file "$DATADIR/archetypes" 3315 load_resource_file "$DATADIR/archetypes"
3148 or die "unable to load archetypes\n"; 3316 or die "unable to load archetypes\n";
3149 #d# NEED to laod twice to resolve forward references
3150 # this really needs to be done in an extra post-pass
3151 # (which needs to be synchronous, so solve it differently)
3152 load_resource_file "$DATADIR/archetypes"
3153 or die "unable to load archetypes\n";
3154} 3317}
3155 3318
3156sub reload_treasures { 3319sub reload_treasures {
3157 load_resource_file "$DATADIR/treasures" 3320 load_resource_file "$DATADIR/treasures"
3158 or die "unable to load treasurelists\n"; 3321 or die "unable to load treasurelists\n";
3159} 3322}
3160 3323
3161sub reload_resources { 3324sub reload_resources {
3162 warn "reloading resource files...\n"; 3325 warn "reloading resource files...\n";
3163 3326
3327 reload_facedata;
3328 reload_archetypes;
3164 reload_regions; 3329 reload_regions;
3165 reload_facedata;
3166 #reload_archetypes;#d#
3167 reload_archetypes;
3168 reload_treasures; 3330 reload_treasures;
3169 3331
3170 warn "finished reloading resource files\n"; 3332 warn "finished reloading resource files\n";
3171} 3333}
3172 3334
3173sub init { 3335sub init {
3336 my $guard = freeze_mainloop;
3337
3338 evthread_start IO::AIO::poll_fileno;
3339
3174 reload_resources; 3340 reload_resources;
3175} 3341}
3176 3342
3177sub reload_config { 3343sub reload_config {
3178 open my $fh, "<:utf8", "$CONFDIR/config" 3344 open my $fh, "<:utf8", "$CONFDIR/config"
3179 or return; 3345 or return;
3180 3346
3181 local $/; 3347 local $/;
3182 *CFG = YAML::Syck::Load <$fh>; 3348 *CFG = YAML::Load <$fh>;
3183 3349
3184 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3350 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3185 3351
3186 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3352 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3187 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3353 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3193 }; 3359 };
3194 warn $@ if $@; 3360 warn $@ if $@;
3195 } 3361 }
3196} 3362}
3197 3363
3364sub pidfile() {
3365 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3366 or die "$PIDFILE: $!";
3367 flock $fh, &Fcntl::LOCK_EX
3368 or die "$PIDFILE: flock: $!";
3369 $fh
3370}
3371
3372# make sure only one server instance is running at any one time
3373sub atomic {
3374 my $fh = pidfile;
3375
3376 my $pid = <$fh>;
3377 kill 9, $pid if $pid > 0;
3378
3379 seek $fh, 0, 0;
3380 print $fh $$;
3381}
3382
3198sub main { 3383sub main {
3384 atomic;
3385
3199 # we must not ever block the main coroutine 3386 # we must not ever block the main coroutine
3200 local $Coro::idle = sub { 3387 local $Coro::idle = sub {
3201 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3388 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3202 (async { 3389 (async {
3203 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3390 $Coro::current->{desc} = "IDLE BUG HANDLER";
3204 Event::one_event; 3391 EV::loop EV::LOOP_ONESHOT;
3205 })->prio (Coro::PRIO_MAX); 3392 })->prio (Coro::PRIO_MAX);
3206 }; 3393 };
3207 3394
3395 {
3396 my $guard = freeze_mainloop;
3208 reload_config; 3397 reload_config;
3209 db_init; 3398 db_init;
3210 load_extensions; 3399 load_extensions;
3211 3400
3212 $TICK_WATCHER->start; 3401 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3402 }
3403
3404 utime time, time, $RUNTIMEFILE;
3405
3406 # no (long-running) fork's whatsoever before this point(!)
3407 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3408
3213 Event::loop; 3409 EV::loop;
3214} 3410}
3215 3411
3216############################################################################# 3412#############################################################################
3217# initialisation and cleanup 3413# initialisation and cleanup
3218 3414
3219# install some emergency cleanup handlers 3415# install some emergency cleanup handlers
3220BEGIN { 3416BEGIN {
3417 our %SIGWATCHER = ();
3221 for my $signal (qw(INT HUP TERM)) { 3418 for my $signal (qw(INT HUP TERM)) {
3222 Event->signal ( 3419 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3223 reentrant => 0,
3224 data => WF_AUTOCANCEL,
3225 signal => $signal,
3226 prio => 0,
3227 cb => sub {
3228 cf::cleanup "SIG$signal"; 3420 cf::cleanup "SIG$signal";
3229 },
3230 ); 3421 };
3231 } 3422 }
3232} 3423}
3233 3424
3234sub write_runtime { 3425sub write_runtime_sync {
3235 my $runtime = "$LOCALDIR/runtime";
3236
3237 # first touch the runtime file to show we are still running: 3426 # first touch the runtime file to show we are still running:
3238 # the fsync below can take a very very long time. 3427 # the fsync below can take a very very long time.
3239 3428
3240 IO::AIO::aio_utime $runtime, undef, undef; 3429 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3241 3430
3242 my $guard = cf::lock_acquire "write_runtime"; 3431 my $guard = cf::lock_acquire "write_runtime";
3243 3432
3244 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3433 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3245 or return; 3434 or return;
3246 3435
3247 my $value = $cf::RUNTIME + 90 + 10; 3436 my $value = $cf::RUNTIME + 90 + 10;
3248 # 10 is the runtime save interval, for a monotonic clock 3437 # 10 is the runtime save interval, for a monotonic clock
3249 # 60 allows for the watchdog to kill the server. 3438 # 60 allows for the watchdog to kill the server.
3259 aio_utime $fh, undef, undef; 3448 aio_utime $fh, undef, undef;
3260 3449
3261 close $fh 3450 close $fh
3262 or return; 3451 or return;
3263 3452
3264 aio_rename "$runtime~", $runtime 3453 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3265 and return; 3454 and return;
3266 3455
3267 warn "runtime file written.\n"; 3456 warn "runtime file written.\n";
3268 3457
3269 1 3458 1
3459}
3460
3461our $uuid_lock;
3462our $uuid_skip;
3463
3464sub write_uuid_sync($) {
3465 $uuid_skip ||= $_[0];
3466
3467 return if $uuid_lock;
3468 local $uuid_lock = 1;
3469
3470 my $uuid = "$LOCALDIR/uuid";
3471
3472 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3473 or return;
3474
3475 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;
3476 $uuid_skip = 0;
3477
3478 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3479 and return;
3480
3481 # always fsync - this file is important
3482 aio_fsync $fh
3483 and return;
3484
3485 close $fh
3486 or return;
3487
3488 aio_rename "$uuid~", $uuid
3489 and return;
3490
3491 warn "uuid file written ($value).\n";
3492
3493 1
3494
3495}
3496
3497sub write_uuid($$) {
3498 my ($skip, $sync) = @_;
3499
3500 $sync ? write_uuid_sync $skip
3501 : async { write_uuid_sync $skip };
3270} 3502}
3271 3503
3272sub emergency_save() { 3504sub emergency_save() {
3273 my $freeze_guard = cf::freeze_mainloop; 3505 my $freeze_guard = cf::freeze_mainloop;
3274 3506
3296 warn "end emergency map save\n"; 3528 warn "end emergency map save\n";
3297 3529
3298 warn "begin emergency database checkpoint\n"; 3530 warn "begin emergency database checkpoint\n";
3299 BDB::db_env_txn_checkpoint $DB_ENV; 3531 BDB::db_env_txn_checkpoint $DB_ENV;
3300 warn "end emergency database checkpoint\n"; 3532 warn "end emergency database checkpoint\n";
3533
3534 warn "begin write uuid\n";
3535 write_uuid_sync 1;
3536 warn "end write uuid\n";
3301 }; 3537 };
3302 3538
3303 warn "leave emergency perl save\n"; 3539 warn "leave emergency perl save\n";
3304} 3540}
3305 3541
3306sub post_cleanup { 3542sub post_cleanup {
3307 my ($make_core) = @_; 3543 my ($make_core) = @_;
3308 3544
3309 warn Carp::longmess "post_cleanup backtrace" 3545 warn Carp::longmess "post_cleanup backtrace"
3310 if $make_core; 3546 if $make_core;
3547
3548 my $fh = pidfile;
3549 unlink $PIDFILE if <$fh> == $$;
3311} 3550}
3551
3552# a safer delete_package, copied from Symbol
3553sub clear_package($) {
3554 my $pkg = shift;
3555
3556 # expand to full symbol table name if needed
3557 unless ($pkg =~ /^main::.*::$/) {
3558 $pkg = "main$pkg" if $pkg =~ /^::/;
3559 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3560 $pkg .= '::' unless $pkg =~ /::$/;
3561 }
3562
3563 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3564 my $stem_symtab = *{$stem}{HASH};
3565
3566 defined $stem_symtab and exists $stem_symtab->{$leaf}
3567 or return;
3568
3569 # clear all symbols
3570 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3571 for my $name (keys %$leaf_symtab) {
3572 _gv_clear *{"$pkg$name"};
3573# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3574 }
3575 warn "cleared package #$pkg\n";#d#
3576}
3577
3578our $RELOAD; # how many times to reload
3312 3579
3313sub do_reload_perl() { 3580sub do_reload_perl() {
3314 # can/must only be called in main 3581 # can/must only be called in main
3315 if ($Coro::current != $Coro::main) { 3582 if ($Coro::current != $Coro::main) {
3316 warn "can only reload from main coroutine"; 3583 warn "can only reload from main coroutine";
3317 return; 3584 return;
3318 } 3585 }
3319 3586
3587 return if $RELOAD++;
3588
3589 while ($RELOAD) {
3320 warn "reloading..."; 3590 warn "reloading...";
3321 3591
3322 warn "entering sync_job"; 3592 warn "entering sync_job";
3323 3593
3324 cf::sync_job { 3594 cf::sync_job {
3325 cf::write_runtime; # external watchdog should not bark 3595 cf::write_runtime_sync; # external watchdog should not bark
3326 cf::emergency_save; 3596 cf::emergency_save;
3327 cf::write_runtime; # external watchdog should not bark 3597 cf::write_runtime_sync; # external watchdog should not bark
3328 3598
3329 warn "syncing database to disk"; 3599 warn "syncing database to disk";
3330 BDB::db_env_txn_checkpoint $DB_ENV; 3600 BDB::db_env_txn_checkpoint $DB_ENV;
3331 3601
3332 # if anything goes wrong in here, we should simply crash as we already saved 3602 # if anything goes wrong in here, we should simply crash as we already saved
3333 3603
3334 warn "cancelling all WF_AUTOCANCEL watchers";
3335 for (Event::all_watchers) {
3336 $_->cancel if $_->data & WF_AUTOCANCEL;
3337 }
3338
3339 warn "flushing outstanding aio requests"; 3604 warn "flushing outstanding aio requests";
3340 for (;;) {
3341 BDB::flush;
3342 IO::AIO::flush;
3343 Coro::cede;
3344 last unless IO::AIO::nreqs || BDB::nreqs; 3605 while (IO::AIO::nreqs || BDB::nreqs) {
3345 warn "iterate..."; 3606 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3346 }
3347
3348 ++$RELOAD;
3349
3350 warn "cancelling all extension coros";
3351 $_->cancel for values %EXT_CORO;
3352 %EXT_CORO = ();
3353
3354 warn "removing commands";
3355 %COMMAND = ();
3356
3357 warn "removing ext/exti commands";
3358 %EXTCMD = ();
3359 %EXTICMD = ();
3360
3361 warn "unloading/nuking all extensions";
3362 for my $pkg (@EXTS) {
3363 warn "... unloading $pkg";
3364
3365 if (my $cb = $pkg->can ("unload")) {
3366 eval {
3367 $cb->($pkg);
3368 1
3369 } or warn "$pkg unloaded, but with errors: $@";
3370 } 3607 }
3371 3608
3372 warn "... nuking $pkg"; 3609 warn "cancelling all extension coros";
3373 Symbol::delete_package $pkg; 3610 $_->cancel for values %EXT_CORO;
3374 } 3611 %EXT_CORO = ();
3375 3612
3376 warn "unloading all perl modules loaded from $LIBDIR"; 3613 warn "removing commands";
3377 while (my ($k, $v) = each %INC) { 3614 %COMMAND = ();
3378 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3379 3615
3616 warn "removing ext/exti commands";
3617 %EXTCMD = ();
3618 %EXTICMD = ();
3619
3620 warn "unloading/nuking all extensions";
3621 for my $pkg (@EXTS) {
3380 warn "... unloading $k"; 3622 warn "... unloading $pkg";
3381 delete $INC{$k};
3382 3623
3383 $k =~ s/\.pm$//;
3384 $k =~ s/\//::/g;
3385
3386 if (my $cb = $k->can ("unload_module")) { 3624 if (my $cb = $pkg->can ("unload")) {
3625 eval {
3387 $cb->(); 3626 $cb->($pkg);
3627 1
3628 } or warn "$pkg unloaded, but with errors: $@";
3629 }
3630
3631 warn "... clearing $pkg";
3632 clear_package $pkg;
3388 } 3633 }
3389 3634
3390 Symbol::delete_package $k; 3635 warn "unloading all perl modules loaded from $LIBDIR";
3636 while (my ($k, $v) = each %INC) {
3637 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3638
3639 warn "... unloading $k";
3640 delete $INC{$k};
3641
3642 $k =~ s/\.pm$//;
3643 $k =~ s/\//::/g;
3644
3645 if (my $cb = $k->can ("unload_module")) {
3646 $cb->();
3647 }
3648
3649 clear_package $k;
3391 } 3650 }
3392 3651
3393 warn "getting rid of safe::, as good as possible"; 3652 warn "getting rid of safe::, as good as possible";
3394 Symbol::delete_package "safe::$_" 3653 clear_package "safe::$_"
3395 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3654 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3396 3655
3397 warn "unloading cf.pm \"a bit\""; 3656 warn "unloading cf.pm \"a bit\"";
3398 delete $INC{"cf.pm"}; 3657 delete $INC{"cf.pm"};
3399 delete $INC{"cf/pod.pm"}; 3658 delete $INC{"cf/pod.pm"};
3400 3659
3401 # don't, removes xs symbols, too, 3660 # don't, removes xs symbols, too,
3402 # and global variables created in xs 3661 # and global variables created in xs
3403 #Symbol::delete_package __PACKAGE__; 3662 #clear_package __PACKAGE__;
3404 3663
3405 warn "unload completed, starting to reload now"; 3664 warn "unload completed, starting to reload now";
3406 3665
3407 warn "reloading cf.pm"; 3666 warn "reloading cf.pm";
3408 require cf; 3667 require cf;
3409 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3668 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3410 3669
3411 warn "loading config and database again"; 3670 warn "loading config and database again";
3412 cf::reload_config; 3671 cf::reload_config;
3413 3672
3414 warn "loading extensions"; 3673 warn "loading extensions";
3415 cf::load_extensions; 3674 cf::load_extensions;
3416 3675
3417 warn "reattaching attachments to objects/players"; 3676 warn "reattaching attachments to objects/players";
3418 _global_reattach; # objects, sockets 3677 _global_reattach; # objects, sockets
3419 warn "reattaching attachments to maps"; 3678 warn "reattaching attachments to maps";
3420 reattach $_ for values %MAP; 3679 reattach $_ for values %MAP;
3421 warn "reattaching attachments to players"; 3680 warn "reattaching attachments to players";
3422 reattach $_ for values %PLAYER; 3681 reattach $_ for values %PLAYER;
3423 3682
3424 warn "leaving sync_job"; 3683 warn "leaving sync_job";
3425 3684
3426 1 3685 1
3427 } or do { 3686 } or do {
3428 warn $@; 3687 warn $@;
3429 warn "error while reloading, exiting."; 3688 cf::cleanup "error while reloading, exiting.";
3430 exit 1;
3431 }; 3689 };
3432 3690
3433 warn "reloaded"; 3691 warn "reloaded";
3692 --$RELOAD;
3693 }
3434}; 3694};
3435 3695
3436our $RELOAD_WATCHER; # used only during reload 3696our $RELOAD_WATCHER; # used only during reload
3437 3697
3438sub reload_perl() { 3698sub reload_perl() {
3439 # doing reload synchronously and two reloads happen back-to-back, 3699 # doing reload synchronously and two reloads happen back-to-back,
3440 # coro crashes during coro_state_free->destroy here. 3700 # coro crashes during coro_state_free->destroy here.
3441 3701
3442 $RELOAD_WATCHER ||= Event->timer ( 3702 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3443 reentrant => 0,
3444 after => 0,
3445 data => WF_AUTOCANCEL,
3446 cb => sub {
3447 do_reload_perl; 3703 do_reload_perl;
3448 undef $RELOAD_WATCHER; 3704 undef $RELOAD_WATCHER;
3449 },
3450 ); 3705 };
3451} 3706}
3452 3707
3453register_command "reload" => sub { 3708register_command "reload" => sub {
3454 my ($who, $arg) = @_; 3709 my ($who, $arg) = @_;
3455 3710
3468 3723
3469our @WAIT_FOR_TICK; 3724our @WAIT_FOR_TICK;
3470our @WAIT_FOR_TICK_BEGIN; 3725our @WAIT_FOR_TICK_BEGIN;
3471 3726
3472sub wait_for_tick { 3727sub wait_for_tick {
3473 return unless $TICK_WATCHER->is_active;
3474 return if $Coro::current == $Coro::main; 3728 return if tick_inhibit || $Coro::current == $Coro::main;
3475 3729
3476 my $signal = new Coro::Signal; 3730 my $signal = new Coro::Signal;
3477 push @WAIT_FOR_TICK, $signal; 3731 push @WAIT_FOR_TICK, $signal;
3478 $signal->wait; 3732 $signal->wait;
3479} 3733}
3480 3734
3481sub wait_for_tick_begin { 3735sub wait_for_tick_begin {
3482 return unless $TICK_WATCHER->is_active;
3483 return if $Coro::current == $Coro::main; 3736 return if tick_inhibit || $Coro::current == $Coro::main;
3484 3737
3485 my $signal = new Coro::Signal; 3738 my $signal = new Coro::Signal;
3486 push @WAIT_FOR_TICK_BEGIN, $signal; 3739 push @WAIT_FOR_TICK_BEGIN, $signal;
3487 $signal->wait; 3740 $signal->wait;
3488} 3741}
3489 3742
3490$TICK_WATCHER = Event->timer ( 3743sub tick {
3491 reentrant => 0,
3492 parked => 1,
3493 prio => 0,
3494 at => $NEXT_TICK || $TICK,
3495 data => WF_AUTOCANCEL,
3496 cb => sub {
3497 if ($Coro::current != $Coro::main) { 3744 if ($Coro::current != $Coro::main) {
3498 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3745 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3499 unless ++$bug_warning > 10; 3746 unless ++$bug_warning > 10;
3500 return; 3747 return;
3501 } 3748 }
3502 3749
3503 $NOW = $tick_start = Event::time;
3504
3505 cf::server_tick; # one server iteration 3750 cf::server_tick; # one server iteration
3506 3751
3507 $RUNTIME += $TICK;
3508 $NEXT_TICK += $TICK;
3509
3510 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3752 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3511 $NEXT_RUNTIME_WRITE = $NOW + 10; 3753 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3512 Coro::async_pool { 3754 Coro::async_pool {
3513 $Coro::current->{desc} = "runtime saver"; 3755 $Coro::current->{desc} = "runtime saver";
3514 write_runtime 3756 write_runtime_sync
3515 or warn "ERROR: unable to write runtime file: $!"; 3757 or warn "ERROR: unable to write runtime file: $!";
3516 };
3517 } 3758 };
3759 }
3518 3760
3519 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3761 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3520 $sig->send; 3762 $sig->send;
3521 } 3763 }
3522 while (my $sig = shift @WAIT_FOR_TICK) { 3764 while (my $sig = shift @WAIT_FOR_TICK) {
3523 $sig->send; 3765 $sig->send;
3524 } 3766 }
3525 3767
3526 $NOW = Event::time; 3768 $LOAD = ($NOW - $TICK_START) / $TICK;
3527
3528 # if we are delayed by four ticks or more, skip them all
3529 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3530
3531 $TICK_WATCHER->at ($NEXT_TICK);
3532 $TICK_WATCHER->start;
3533
3534 $LOAD = ($NOW - $tick_start) / $TICK;
3535 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3769 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3536 3770
3537 _post_tick; 3771 if (0) {
3772 if ($NEXT_TICK) {
3773 my $jitter = $TICK_START - $NEXT_TICK;
3774 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3775 warn "jitter $JITTER\n";#d#
3776 }
3538 }, 3777 }
3539); 3778}
3540 3779
3541{ 3780{
3781 # configure BDB
3782
3542 BDB::min_parallel 8; 3783 BDB::min_parallel 8;
3543 BDB::max_poll_time $TICK * 0.1; 3784 BDB::max_poll_reqs $TICK * 0.1;
3544 $BDB_POLL_WATCHER = Event->io ( 3785 $AnyEvent::BDB::WATCHER->priority (1);
3545 reentrant => 0,
3546 fd => BDB::poll_fileno,
3547 poll => 'r',
3548 prio => 0,
3549 data => WF_AUTOCANCEL,
3550 cb => \&BDB::poll_cb,
3551 );
3552
3553 BDB::set_sync_prepare {
3554 my $status;
3555 my $current = $Coro::current;
3556 (
3557 sub {
3558 $status = $!;
3559 $current->ready; undef $current;
3560 },
3561 sub {
3562 Coro::schedule while defined $current;
3563 $! = $status;
3564 },
3565 )
3566 };
3567 3786
3568 unless ($DB_ENV) { 3787 unless ($DB_ENV) {
3569 $DB_ENV = BDB::db_env_create; 3788 $DB_ENV = BDB::db_env_create;
3570 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3789 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3571 | BDB::LOG_AUTOREMOVE, 1); 3790 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3791 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3572 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 3792 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3573 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 3793 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3574 3794
3575 cf::sync_job { 3795 cf::sync_job {
3576 eval { 3796 eval {
3586 3806
3587 cf::cleanup "db_env_open(db): $@" if $@; 3807 cf::cleanup "db_env_open(db): $@" if $@;
3588 }; 3808 };
3589 } 3809 }
3590 3810
3591 $BDB_DEADLOCK_WATCHER = Event->timer ( 3811 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3592 after => 3,
3593 interval => 1,
3594 hard => 1,
3595 prio => 0,
3596 data => WF_AUTOCANCEL,
3597 cb => sub {
3598 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { }; 3812 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3599 },
3600 ); 3813 };
3601 $BDB_CHECKPOINT_WATCHER = Event->timer ( 3814 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3602 after => 11,
3603 interval => 60,
3604 hard => 1,
3605 prio => 0,
3606 data => WF_AUTOCANCEL,
3607 cb => sub {
3608 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 3815 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3609 },
3610 ); 3816 };
3611 $BDB_TRICKLE_WATCHER = Event->timer ( 3817 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3612 after => 5,
3613 interval => 10,
3614 hard => 1,
3615 prio => 0,
3616 data => WF_AUTOCANCEL,
3617 cb => sub {
3618 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 3818 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3619 },
3620 ); 3819 };
3621} 3820}
3622 3821
3623{ 3822{
3823 # configure IO::AIO
3824
3624 IO::AIO::min_parallel 8; 3825 IO::AIO::min_parallel 8;
3625
3626 undef $Coro::AIO::WATCHER;
3627 IO::AIO::max_poll_time $TICK * 0.1; 3826 IO::AIO::max_poll_time $TICK * 0.1;
3628 $AIO_POLL_WATCHER = Event->io ( 3827 undef $AnyEvent::AIO::WATCHER;
3629 reentrant => 0,
3630 data => WF_AUTOCANCEL,
3631 fd => IO::AIO::poll_fileno,
3632 poll => 'r',
3633 prio => 0,
3634 cb => \&IO::AIO::poll_cb,
3635 );
3636} 3828}
3637 3829
3638my $_log_backtrace; 3830my $_log_backtrace;
3639 3831
3640sub _log_backtrace { 3832sub _log_backtrace {
3643 $msg =~ s/\n//; 3835 $msg =~ s/\n//;
3644 3836
3645 # limit the # of concurrent backtraces 3837 # limit the # of concurrent backtraces
3646 if ($_log_backtrace < 2) { 3838 if ($_log_backtrace < 2) {
3647 ++$_log_backtrace; 3839 ++$_log_backtrace;
3840 my $perl_bt = Carp::longmess $msg;
3648 async { 3841 async {
3649 $Coro::current->{desc} = "abt $msg"; 3842 $Coro::current->{desc} = "abt $msg";
3650 3843
3651 my @bt = fork_call { 3844 my @bt = fork_call {
3652 @addr = map { sprintf "%x", $_ } @addr; 3845 @addr = map { sprintf "%x", $_ } @addr;
3663 } 3856 }
3664 3857
3665 @funcs 3858 @funcs
3666 }; 3859 };
3667 3860
3668 LOG llevInfo, "[ABT] $msg\n"; 3861 LOG llevInfo, "[ABT] $perl_bt\n";
3862 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3669 LOG llevInfo, "[ABT] $_\n" for @bt; 3863 LOG llevInfo, "[ABT] $_\n" for @bt;
3670 --$_log_backtrace; 3864 --$_log_backtrace;
3671 }; 3865 };
3672 } else { 3866 } else {
3673 LOG llevInfo, "[ABT] $msg\n"; 3867 LOG llevInfo, "[ABT] $msg\n";

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines