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.396 by root, Wed Nov 14 08:09:46 2007 UTC vs.
Revision 1.410 by root, Tue Jan 15 12:02:24 2008 UTC

… …
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket; 8use Socket;
9use EV; 9use EV 1.86;
10use Opcode; 10use Opcode;
11use Safe; 11use Safe;
12use Safe::Hole; 12use Safe::Hole;
13use Storable (); 13use Storable ();
14 14
15use Coro 4.1 (); 15use Coro 4.32 ();
16use Coro::State; 16use Coro::State;
17use Coro::Handle; 17use Coro::Handle;
18use Coro::EV; 18use Coro::EV;
19use Coro::Timer; 19use Coro::Timer;
20use Coro::Signal; 20use Coro::Signal;
21use Coro::Semaphore; 21use Coro::Semaphore;
22use Coro::AIO; 22use Coro::AIO;
23use Coro::BDB;
23use Coro::Storable; 24use Coro::Storable;
24use Coro::Util (); 25use Coro::Util ();
25 26
26use JSON::XS (); 27use JSON::XS 2.01 ();
27use BDB (); 28use BDB ();
28use Data::Dumper; 29use Data::Dumper;
29use Digest::MD5; 30use Digest::MD5;
30use Fcntl; 31use Fcntl;
31use YAML::Syck (); 32use YAML ();
32use IO::AIO 2.51 (); 33use IO::AIO 2.51 ();
33use Time::HiRes; 34use Time::HiRes;
34use Compress::LZF; 35use Compress::LZF;
35use Digest::MD5 (); 36use Digest::MD5 ();
36 37
37# configure various modules to our taste 38# configure various modules to our taste
38# 39#
39$Storable::canonical = 1; # reduce rsync transfers 40$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 41Coro::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 42Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
42
43# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
44$YAML::Syck::ImplicitUnicode = 1;
45 43
46$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 44$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
47 45
48sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 46sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
49 47
… …
68our $TMPDIR = "$LOCALDIR/" . tmpdir; 66our $TMPDIR = "$LOCALDIR/" . tmpdir;
69our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
70our $PLAYERDIR = "$LOCALDIR/" . playerdir; 68our $PLAYERDIR = "$LOCALDIR/" . playerdir;
71our $RANDOMDIR = "$LOCALDIR/random"; 69our $RANDOMDIR = "$LOCALDIR/random";
72our $BDBDIR = "$LOCALDIR/db"; 70our $BDBDIR = "$LOCALDIR/db";
71our %RESOURCE;
73 72
74our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 73our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
75our $TICK_WATCHER; 74our $TICK_WATCHER;
76our $AIO_POLL_WATCHER; 75our $AIO_POLL_WATCHER;
77our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 76our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
78our $NEXT_TICK; 77our $NEXT_TICK;
79our $NOW;
80our $USE_FSYNC = 1; # use fsync to write maps - default off 78our $USE_FSYNC = 1; # use fsync to write maps - default off
81 79
82our $BDB_POLL_WATCHER; 80our $BDB_POLL_WATCHER;
83our $BDB_DEADLOCK_WATCHER; 81our $BDB_DEADLOCK_WATCHER;
84our $BDB_CHECKPOINT_WATCHER; 82our $BDB_CHECKPOINT_WATCHER;
… …
87 85
88our %CFG; 86our %CFG;
89 87
90our $UPTIME; $UPTIME ||= time; 88our $UPTIME; $UPTIME ||= time;
91our $RUNTIME; 89our $RUNTIME;
90our $NOW;
92 91
93our (%PLAYER, %PLAYER_LOADING); # all users 92our (%PLAYER, %PLAYER_LOADING); # all users
94our (%MAP, %MAP_LOADING ); # all maps 93our (%MAP, %MAP_LOADING ); # all maps
95our $LINK_MAP; # the special {link} map, which is always available 94our $LINK_MAP; # the special {link} map, which is always available
96 95
… …
191 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
192 191
193 LOG llevError, $msg; 192 LOG llevError, $msg;
194 }; 193 };
195} 194}
195
196$Coro::State::DIEHOOK = sub {
197 return unless $^S eq 0; # "eq", not "=="
198
199 if ($Coro::current == $Coro::main) {#d#
200 warn "DIEHOOK called in main context, Coro bug?\n";#d#
201 return;#d#
202 }#d#
203
204 # kill coroutine otherwise
205 warn Carp::longmess $_[0];
206 Coro::terminate
207};
208
209$SIG{__DIE__} = sub { }; #d#?
196 210
197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 211@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
198@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 212@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
199@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 213@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
200@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 214@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
246 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 260 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
247 $d 261 $d
248 } || "[unable to dump $_[0]: '$@']"; 262 } || "[unable to dump $_[0]: '$@']";
249} 263}
250 264
251=item $ref = cf::from_json $json 265=item $ref = cf::decode_json $json
252 266
253Converts a JSON string into the corresponding perl data structure. 267Converts a JSON string into the corresponding perl data structure.
254 268
255=item $json = cf::to_json $ref 269=item $json = cf::encode_json $ref
256 270
257Converts a perl data structure into its JSON representation. 271Converts a perl data structure into its JSON representation.
258 272
259=cut 273=cut
260 274
261our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 275our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
262 276
263sub to_json ($) { $json_coder->encode ($_[0]) } 277sub encode_json($) { $json_coder->encode ($_[0]) }
264sub from_json ($) { $json_coder->decode ($_[0]) } 278sub decode_json($) { $json_coder->decode ($_[0]) }
265 279
266=item cf::lock_wait $string 280=item cf::lock_wait $string
267 281
268Wait until the given lock is available. See cf::lock_acquire. 282Wait until the given lock is available. See cf::lock_acquire.
269 283
… …
967 } 981 }
968 982
969 0 983 0
970} 984}
971 985
972=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 986=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
973 987
974=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 988=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
975 989
976Generate an object-specific event with the given arguments. 990Generate an object-specific event with the given arguments.
977 991
… …
1055cf::attachable->attach ( 1069cf::attachable->attach (
1056 prio => -1000000, 1070 prio => -1000000,
1057 on_instantiate => sub { 1071 on_instantiate => sub {
1058 my ($obj, $data) = @_; 1072 my ($obj, $data) = @_;
1059 1073
1060 $data = from_json $data; 1074 $data = decode_json $data;
1061 1075
1062 for (@$data) { 1076 for (@$data) {
1063 my ($name, $args) = @$_; 1077 my ($name, $args) = @$_;
1064 1078
1065 $obj->attach ($name, %{$args || {} }); 1079 $obj->attach ($name, %{$args || {} });
… …
2638 $rmp->{origin_y} = $exit->y; 2652 $rmp->{origin_y} = $exit->y;
2639 } 2653 }
2640 2654
2641 $rmp->{random_seed} ||= $exit->random_seed; 2655 $rmp->{random_seed} ||= $exit->random_seed;
2642 2656
2643 my $data = cf::to_json $rmp; 2657 my $data = cf::encode_json $rmp;
2644 my $md5 = Digest::MD5::md5_hex $data; 2658 my $md5 = Digest::MD5::md5_hex $data;
2645 my $meta = "$RANDOMDIR/$md5.meta"; 2659 my $meta = "$RANDOMDIR/$md5.meta";
2646 2660
2647 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2661 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2648 aio_write $fh, 0, (length $data), $data, 0; 2662 aio_write $fh, 0, (length $data), $data, 0;
… …
3148 { 3162 {
3149 my $faces = $facedata->{faceinfo}; 3163 my $faces = $facedata->{faceinfo};
3150 3164
3151 while (my ($face, $info) = each %$faces) { 3165 while (my ($face, $info) = each %$faces) {
3152 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3166 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3167
3153 cf::face::set_visibility $idx, $info->{visibility}; 3168 cf::face::set_visibility $idx, $info->{visibility};
3154 cf::face::set_magicmap $idx, $info->{magicmap}; 3169 cf::face::set_magicmap $idx, $info->{magicmap};
3155 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3170 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
3156 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3171 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3157 3172
3158 cf::cede_to_tick; 3173 cf::cede_to_tick;
3159 } 3174 }
3160 3175
3161 while (my ($face, $info) = each %$faces) { 3176 while (my ($face, $info) = each %$faces) {
3162 next unless $info->{smooth}; 3177 next unless $info->{smooth};
3178
3163 my $idx = cf::face::find $face 3179 my $idx = cf::face::find $face
3164 or next; 3180 or next;
3181
3165 if (my $smooth = cf::face::find $info->{smooth}) { 3182 if (my $smooth = cf::face::find $info->{smooth}) {
3166 cf::face::set_smooth $idx, $smooth; 3183 cf::face::set_smooth $idx, $smooth;
3167 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3184 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3168 } else { 3185 } else {
3169 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3186 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
3187 { 3204 {
3188 # TODO: for gcfclient pleasure, we should give resources 3205 # TODO: for gcfclient pleasure, we should give resources
3189 # that gcfclient doesn't grok a >10000 face index. 3206 # that gcfclient doesn't grok a >10000 face index.
3190 my $res = $facedata->{resource}; 3207 my $res = $facedata->{resource};
3191 3208
3192 my $soundconf = delete $res->{"res/sound.conf"};
3193
3194 while (my ($name, $info) = each %$res) { 3209 while (my ($name, $info) = each %$res) {
3210 if (defined $info->{type}) {
3195 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3211 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3196 my $data; 3212 my $data;
3197 3213
3198 if ($info->{type} & 1) { 3214 if ($info->{type} & 1) {
3199 # prepend meta info 3215 # prepend meta info
3200 3216
3201 my $meta = $enc->encode ({ 3217 my $meta = $enc->encode ({
3202 name => $name, 3218 name => $name,
3203 %{ $info->{meta} || {} }, 3219 %{ $info->{meta} || {} },
3204 }); 3220 });
3205 3221
3206 $data = pack "(w/a*)*", $meta, $info->{data}; 3222 $data = pack "(w/a*)*", $meta, $info->{data};
3223 } else {
3224 $data = $info->{data};
3225 }
3226
3227 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3228 cf::face::set_type $idx, $info->{type};
3207 } else { 3229 } else {
3208 $data = $info->{data}; 3230 $RESOURCE{$name} = $info;
3209 } 3231 }
3210 3232
3211 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3212 cf::face::set_type $idx, $info->{type};
3213
3214 cf::cede_to_tick; 3233 cf::cede_to_tick;
3215 } 3234 }
3216
3217 if ($soundconf) {
3218 $soundconf = $enc->decode (delete $soundconf->{data});
3219
3220 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3221 my $sound = $soundconf->{compat}[$_]
3222 or next;
3223
3224 my $face = cf::face::find "sound/$sound->[1]";
3225 cf::sound::set $sound->[0] => $face;
3226 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3227 }
3228
3229 while (my ($k, $v) = each %{$soundconf->{event}}) {
3230 my $face = cf::face::find "sound/$v";
3231 cf::sound::set $k => $face;
3232 }
3233 }
3234 } 3235 }
3236
3237 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3235 3238
3236 1 3239 1
3237} 3240}
3241
3242cf::global->attach (on_resource_update => sub {
3243 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3244 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3245
3246 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3247 my $sound = $soundconf->{compat}[$_]
3248 or next;
3249
3250 my $face = cf::face::find "sound/$sound->[1]";
3251 cf::sound::set $sound->[0] => $face;
3252 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3253 }
3254
3255 while (my ($k, $v) = each %{$soundconf->{event}}) {
3256 my $face = cf::face::find "sound/$v";
3257 cf::sound::set $k => $face;
3258 }
3259 }
3260});
3238 3261
3239register_exticmd fx_want => sub { 3262register_exticmd fx_want => sub {
3240 my ($ns, $want) = @_; 3263 my ($ns, $want) = @_;
3241 3264
3242 while (my ($k, $v) = each %$want) { 3265 while (my ($k, $v) = each %$want) {
… …
3297sub reload_config { 3320sub reload_config {
3298 open my $fh, "<:utf8", "$CONFDIR/config" 3321 open my $fh, "<:utf8", "$CONFDIR/config"
3299 or return; 3322 or return;
3300 3323
3301 local $/; 3324 local $/;
3302 *CFG = YAML::Syck::Load <$fh>; 3325 *CFG = YAML::Load <$fh>;
3303 3326
3304 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3327 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3305 3328
3306 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3329 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3307 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3330 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3328 reload_config; 3351 reload_config;
3329 db_init; 3352 db_init;
3330 load_extensions; 3353 load_extensions;
3331 3354
3332 $TICK_WATCHER->start; 3355 $TICK_WATCHER->start;
3356 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3333 EV::loop; 3357 EV::loop;
3334} 3358}
3335 3359
3336############################################################################# 3360#############################################################################
3337# initialisation and cleanup 3361# initialisation and cleanup
… …
3548sub reload_perl() { 3572sub reload_perl() {
3549 # doing reload synchronously and two reloads happen back-to-back, 3573 # doing reload synchronously and two reloads happen back-to-back,
3550 # coro crashes during coro_state_free->destroy here. 3574 # coro crashes during coro_state_free->destroy here.
3551 3575
3552 $RELOAD_WATCHER ||= EV::timer 0, 0, sub { 3576 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3577 do_reload_perl;
3553 undef $RELOAD_WATCHER; 3578 undef $RELOAD_WATCHER;
3554 do_reload_perl;
3555 }; 3579 };
3556} 3580}
3557 3581
3558register_command "reload" => sub { 3582register_command "reload" => sub {
3559 my ($who, $arg) = @_; 3583 my ($who, $arg) = @_;
… …
3601 3625
3602 $NOW = $tick_start = EV::now; 3626 $NOW = $tick_start = EV::now;
3603 3627
3604 cf::server_tick; # one server iteration 3628 cf::server_tick; # one server iteration
3605 3629
3606 $RUNTIME += $TICK; 3630 $RUNTIME += $TICK;
3607 $NEXT_TICK += $TICK; 3631 $NEXT_TICK = $_[0]->at;
3608 3632
3609 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3633 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3610 $NEXT_RUNTIME_WRITE = $NOW + 10; 3634 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3611 Coro::async_pool { 3635 Coro::async_pool {
3612 $Coro::current->{desc} = "runtime saver"; 3636 $Coro::current->{desc} = "runtime saver";
3613 write_runtime 3637 write_runtime
3614 or warn "ERROR: unable to write runtime file: $!"; 3638 or warn "ERROR: unable to write runtime file: $!";
3615 }; 3639 };
… …
3628 _post_tick; 3652 _post_tick;
3629}; 3653};
3630$TICK_WATCHER->priority (EV::MAXPRI); 3654$TICK_WATCHER->priority (EV::MAXPRI);
3631 3655
3632{ 3656{
3657 # configure BDB
3658
3633 BDB::min_parallel 8; 3659 BDB::min_parallel 8;
3634 BDB::max_poll_time $TICK * 0.1; 3660 BDB::max_poll_reqs $TICK * 0.1;
3635 $BDB_POLL_WATCHER = EV::io BDB::poll_fileno, EV::READ, \&BDB::poll_cb; 3661 $Coro::BDB::WATCHER->priority (1);
3636
3637 BDB::set_sync_prepare {
3638 my $status;
3639 my $current = $Coro::current;
3640 (
3641 sub {
3642 $status = $!;
3643 $current->ready; undef $current;
3644 },
3645 sub {
3646 Coro::schedule while defined $current;
3647 $! = $status;
3648 },
3649 )
3650 };
3651 3662
3652 unless ($DB_ENV) { 3663 unless ($DB_ENV) {
3653 $DB_ENV = BDB::db_env_create; 3664 $DB_ENV = BDB::db_env_create;
3654 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3665 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3655 | BDB::LOG_AUTOREMOVE, 1); 3666 | BDB::LOG_AUTOREMOVE, 1);
… …
3682 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 3693 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3683 }; 3694 };
3684} 3695}
3685 3696
3686{ 3697{
3698 # configure IO::AIO
3699
3687 IO::AIO::min_parallel 8; 3700 IO::AIO::min_parallel 8;
3688
3689 undef $Coro::AIO::WATCHER;
3690 IO::AIO::max_poll_time $TICK * 0.1; 3701 IO::AIO::max_poll_time $TICK * 0.1;
3691 $AIO_POLL_WATCHER = EV::io IO::AIO::poll_fileno, EV::READ, \&IO::AIO::poll_cb; 3702 $Coro::AIO::WATCHER->priority (1);
3692} 3703}
3693 3704
3694my $_log_backtrace; 3705my $_log_backtrace;
3695 3706
3696sub _log_backtrace { 3707sub _log_backtrace {

Diff Legend

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