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.405 by root, Mon Dec 17 08:03:22 2007 UTC vs.
Revision 1.410 by root, Tue Jan 15 12:02:24 2008 UTC

… …
27use JSON::XS 2.01 (); 27use JSON::XS 2.01 ();
28use BDB (); 28use BDB ();
29use Data::Dumper; 29use Data::Dumper;
30use Digest::MD5; 30use Digest::MD5;
31use Fcntl; 31use Fcntl;
32use YAML::Syck (); 32use YAML ();
33use IO::AIO 2.51 (); 33use IO::AIO 2.51 ();
34use Time::HiRes; 34use Time::HiRes;
35use Compress::LZF; 35use Compress::LZF;
36use Digest::MD5 (); 36use Digest::MD5 ();
37 37
38# configure various modules to our taste 38# configure various modules to our taste
39# 39#
40$Storable::canonical = 1; # reduce rsync transfers 40$Storable::canonical = 1; # reduce rsync transfers
41Coro::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
42Compress::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
43
44# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
45$YAML::Syck::ImplicitUnicode = 1;
46 43
47$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
48 45
49sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 46sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
50 47
… …
193 $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;
194 191
195 LOG llevError, $msg; 192 LOG llevError, $msg;
196 }; 193 };
197} 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#?
198 210
199@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 211@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
200@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 212@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
201@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 213@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
202@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 214@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
969 } 981 }
970 982
971 0 983 0
972} 984}
973 985
974=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 986=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
975 987
976=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 988=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
977 989
978Generate an object-specific event with the given arguments. 990Generate an object-specific event with the given arguments.
979 991
… …
3218 $RESOURCE{$name} = $info; 3230 $RESOURCE{$name} = $info;
3219 } 3231 }
3220 3232
3221 cf::cede_to_tick; 3233 cf::cede_to_tick;
3222 } 3234 }
3223
3224 if (my $soundconf = delete $res->{"res/sound.conf"}) {
3225 $soundconf = $enc->decode (delete $soundconf->{data});
3226
3227 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3228 my $sound = $soundconf->{compat}[$_]
3229 or next;
3230
3231 my $face = cf::face::find "sound/$sound->[1]";
3232 cf::sound::set $sound->[0] => $face;
3233 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3234 }
3235
3236 while (my ($k, $v) = each %{$soundconf->{event}}) {
3237 my $face = cf::face::find "sound/$v";
3238 cf::sound::set $k => $face;
3239 }
3240 }
3241 } 3235 }
3236
3237 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3242 3238
3243 1 3239 1
3244} 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});
3245 3261
3246register_exticmd fx_want => sub { 3262register_exticmd fx_want => sub {
3247 my ($ns, $want) = @_; 3263 my ($ns, $want) = @_;
3248 3264
3249 while (my ($k, $v) = each %$want) { 3265 while (my ($k, $v) = each %$want) {
… …
3304sub reload_config { 3320sub reload_config {
3305 open my $fh, "<:utf8", "$CONFDIR/config" 3321 open my $fh, "<:utf8", "$CONFDIR/config"
3306 or return; 3322 or return;
3307 3323
3308 local $/; 3324 local $/;
3309 *CFG = YAML::Syck::Load <$fh>; 3325 *CFG = YAML::Load <$fh>;
3310 3326
3311 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3327 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3312 3328
3313 $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};
3314 $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};
… …
3556sub reload_perl() { 3572sub reload_perl() {
3557 # doing reload synchronously and two reloads happen back-to-back, 3573 # doing reload synchronously and two reloads happen back-to-back,
3558 # coro crashes during coro_state_free->destroy here. 3574 # coro crashes during coro_state_free->destroy here.
3559 3575
3560 $RELOAD_WATCHER ||= EV::timer 0, 0, sub { 3576 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3577 do_reload_perl;
3561 undef $RELOAD_WATCHER; 3578 undef $RELOAD_WATCHER;
3562 do_reload_perl;
3563 }; 3579 };
3564} 3580}
3565 3581
3566register_command "reload" => sub { 3582register_command "reload" => sub {
3567 my ($who, $arg) = @_; 3583 my ($who, $arg) = @_;

Diff Legend

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