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.588 by root, Thu Nov 1 13:02:52 2012 UTC vs.
Revision 1.593 by root, Fri Nov 9 01:59:33 2012 UTC

… …
224=item $cf::RUNTIME 224=item $cf::RUNTIME
225 225
226The time this server has run, starts at 0 and is increased by $cf::TICK on 226The time this server has run, starts at 0 and is increased by $cf::TICK on
227every server tick. 227every server tick.
228 228
229=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR 229=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
230$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR 230$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
231$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR 231$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
232 232
233Various directories - "/etc", read-only install directory, perl-library 233Various directories - "/etc", read-only install directory, perl-library
234directory, pod-directory, read-only maps directory, "/var", "/var/tmp", 234directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
235unique-items directory, player file directory, random maps directory and 235unique-items directory, player file directory, random maps directory and
236database environment. 236database environment.
… …
1431=cut 1431=cut
1432 1432
1433############################################################################# 1433#############################################################################
1434# command handling &c 1434# command handling &c
1435 1435
1436=item cf::register_command $name => \&callback($ob,$args); 1436=item cf::register_command $name => \&callback($ob,$args)
1437 1437
1438Register a callback for execution when the client sends the user command 1438Register a callback for execution when the client sends the user command
1439$name. 1439$name.
1440 1440
1441=cut 1441=cut
… …
1447 #warn "registering command '$name/$time' to '$caller'"; 1447 #warn "registering command '$name/$time' to '$caller'";
1448 1448
1449 push @{ $COMMAND{$name} }, [$caller, $cb]; 1449 push @{ $COMMAND{$name} }, [$caller, $cb];
1450} 1450}
1451 1451
1452=item cf::register_extcmd $name => \&callback($pl,$packet); 1452=item cf::register_extcmd $name => \&callback($pl,$packet)
1453 1453
1454Register a callback for execution when the client sends an (synchronous) 1454Register a callback for execution when the client sends an (synchronous)
1455extcmd packet. Ext commands will be processed in the order they are 1455extcmd packet. Ext commands will be processed in the order they are
1456received by the server, like other user commands. The first argument is 1456received by the server, like other user commands. The first argument is
1457the logged-in player. Ext commands can only be processed after a player 1457the logged-in player. Ext commands can only be processed after a player
1458has logged in successfully. 1458has logged in successfully.
1459 1459
1460If the callback returns something, it is sent back as if reply was being 1460If the callback returns something, it is sent back as if reply was being
1461called. 1461called.
1462 1462
1463=item cf::register_exticmd $name => \&callback($ns,$packet); 1463=item cf::register_exticmd $name => \&callback($ns,$packet)
1464 1464
1465Register a callback for execution when the client sends an (asynchronous) 1465Register a callback for execution when the client sends an (asynchronous)
1466exticmd packet. Exti commands are processed by the server as soon as they 1466exticmd packet. Exti commands are processed by the server as soon as they
1467are received, i.e. out of order w.r.t. other commands. The first argument 1467are received, i.e. out of order w.r.t. other commands. The first argument
1468is a client socket. Exti commands can be received anytime, even before 1468is a client socket. Exti commands can be received anytime, even before
… …
1512 1512
1513 if (my $cb = $EXTCMD{$type}) { 1513 if (my $cb = $EXTCMD{$type}) {
1514 @reply = $cb->($pl, @payload); 1514 @reply = $cb->($pl, @payload);
1515 } 1515 }
1516 1516
1517 $pl->ext_reply ($reply, @reply) 1517 $pl->ext_msg ("reply-$reply", @reply)
1518 if $reply; 1518 if $reply;
1519 1519
1520 } else { 1520 } else {
1521 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1521 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1522 } 1522 }
… …
1909} 1909}
1910 1910
1911=item $protocol_xml = $player->expand_cfpod ($cfpod) 1911=item $protocol_xml = $player->expand_cfpod ($cfpod)
1912 1912
1913Expand deliantra pod fragments into protocol xml. 1913Expand deliantra pod fragments into protocol xml.
1914
1915=item $player->ext_reply ($msgid, @msg)
1916
1917Sends an ext reply to the player.
1918
1919=cut
1920
1921sub ext_reply($$@) {
1922 my ($self, $id, @msg) = @_;
1923
1924 $self->ns->ext_reply ($id, @msg)
1925}
1926 1914
1927=item $player->ext_msg ($type, @msg) 1915=item $player->ext_msg ($type, @msg)
1928 1916
1929Sends an ext event to the client. 1917Sends an ext event to the client.
1930 1918
… …
3235=cut 3223=cut
3236 3224
3237sub cf::client::ext_msg($$@) { 3225sub cf::client::ext_msg($$@) {
3238 my ($self, $type, @msg) = @_; 3226 my ($self, $type, @msg) = @_;
3239 3227
3240 if ($self->extcmd == 2) {
3241 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3228 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3242 } elsif ($self->extcmd == 1) { # TODO: remove
3243 push @msg, msgtype => "event_$type";
3244 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3245 }
3246}
3247
3248=item $client->ext_reply ($msgid, @msg)
3249
3250Sends an ext reply to the client.
3251
3252=cut
3253
3254sub cf::client::ext_reply($$@) {
3255 my ($self, $id, @msg) = @_;
3256
3257 return unless $self->extcmd == 2;
3258
3259 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3260} 3229}
3261 3230
3262=item $success = $client->query ($flags, "text", \&cb) 3231=item $success = $client->query ($flags, "text", \&cb)
3263 3232
3264Queues a query to the client, calling the given callback with 3233Queues a query to the client, calling the given callback with
… …
3327 3296
3328 if (my $cb = $EXTICMD{$type}) { 3297 if (my $cb = $EXTICMD{$type}) {
3329 @reply = $cb->($ns, @payload); 3298 @reply = $cb->($ns, @payload);
3330 } 3299 }
3331 3300
3332 $ns->ext_reply ($reply, @reply) 3301 $ns->ext_msg ("reply-$reply", @reply)
3333 if $reply; 3302 if $reply;
3334 3303
3335 } else { 3304 } else {
3336 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3305 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3337 } 3306 }
… …
3509############################################################################# 3478#############################################################################
3510# the server's init and main functions 3479# the server's init and main functions
3511 3480
3512our %FACEHASH; # hash => idx, #d# HACK for http server 3481our %FACEHASH; # hash => idx, #d# HACK for http server
3513 3482
3483# internal api, not fianlised
3484sub add_face {
3485 my ($name, $type, $data) = @_;
3486
3487 my $idx = cf::face::find $name;
3488
3489 if ($idx) {
3490 delete $FACEHASH{cf::face::get_chksum $idx};
3491 } else {
3492 $idx = cf::face::alloc $name;
3493 }
3494
3495 my $hash = cf::face::mangle_chksum Digest::MD5::md5 $data;
3496
3497 cf::face::set_type $idx, $type;
3498 cf::face::set_data $idx, 0, $data, $hash;
3499 cf::face::set_meta $idx, $type & 1 ? undef : undef;
3500 $FACEHASH{$hash} = $idx;#d#
3501
3502 $idx
3503}
3504
3514sub load_facedata($) { 3505sub load_facedata($) {
3515 my ($path) = @_; 3506 my ($path) = @_;
3516 3507
3517 # HACK to clear player env face cache, we need some signal framework 3508 # HACK to clear player env face cache, we need some signal framework
3518 # for this (global event?) 3509 # for this (global event?)
… …
3525 my $facedata = decode_storable load_file $path; 3516 my $facedata = decode_storable load_file $path;
3526 3517
3527 $facedata->{version} == 2 3518 $facedata->{version} == 2
3528 or cf::cleanup "$path: version mismatch, cannot proceed."; 3519 or cf::cleanup "$path: version mismatch, cannot proceed.";
3529 3520
3530 # patch in the exptable
3531 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3532 $facedata->{resource}{"res/exp_table"} = {
3533 type => FT_RSRC,
3534 data => $exp_table,
3535 hash => (cf::face::mangle_chksum Digest::MD5::md5 $exp_table),
3536 };
3537 cf::cede_to_tick; 3521 cf::cede_to_tick;
3538 3522
3539 { 3523 {
3540 my $faces = $facedata->{faceinfo}; 3524 my $faces = $facedata->{faceinfo};
3541 3525
… …
3587 while (my ($name, $info) = each %$res) { 3571 while (my ($name, $info) = each %$res) {
3588 if (defined (my $type = $info->{type})) { 3572 if (defined (my $type = $info->{type})) {
3589 # TODO: different hash - must free and use new index, or cache ixface data queue 3573 # TODO: different hash - must free and use new index, or cache ixface data queue
3590 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3574 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3591 3575
3576 cf::face::set_type $idx, $type;
3592 cf::face::set_data $idx, 0, $info->{data}, $info->{hash}; 3577 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3593 cf::face::set_type $idx, $type;
3594 cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already 3578 cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3595 $FACEHASH{$info->{hash}} = $idx;#d# 3579 $FACEHASH{$info->{hash}} = $idx;#d#
3596 } else { 3580 } else {
3597# $RESOURCE{$name} = $info; # unused 3581# $RESOURCE{$name} = $info; # unused
3598 } 3582 }
… …
3622 cf::arch::commit_load; 3606 cf::arch::commit_load;
3623 3607
3624 $status 3608 $status
3625} 3609}
3626 3610
3611sub reload_exp_table {
3612 _reload_exp_table;
3613
3614 add_face "res/exp_table" => FT_RSRC,
3615 JSON::XS->new->utf8->canonical->encode (
3616 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
3617 );
3618}
3619
3620sub reload_materials {
3621 _reload_materials;
3622}
3623
3627sub reload_regions { 3624sub reload_regions {
3628 # HACK to clear player env face cache, we need some signal framework 3625 # HACK to clear player env face cache, we need some signal framework
3629 # for this (global event?) 3626 # for this (global event?)
3630 %ext::player_env::MUSIC_FACE_CACHE = (); 3627 %ext::player_env::MUSIC_FACE_CACHE = ();
3631 3628
… …
3644} 3641}
3645 3642
3646sub reload_archetypes { 3643sub reload_archetypes {
3647 load_resource_file "$DATADIR/archetypes" 3644 load_resource_file "$DATADIR/archetypes"
3648 or die "unable to load archetypes\n"; 3645 or die "unable to load archetypes\n";
3646
3647 add_face "res/skill_info" => FT_RSRC,
3648 JSON::XS->new->utf8->canonical->encode (
3649 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
3650 );
3651 add_face "res/spell_paths" => FT_RSRC,
3652 JSON::XS->new->utf8->canonical->encode (
3653 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
3654 );
3649} 3655}
3650 3656
3651sub reload_treasures { 3657sub reload_treasures {
3652 load_resource_file "$DATADIR/treasures" 3658 load_resource_file "$DATADIR/treasures"
3653 or die "unable to load treasurelists\n"; 3659 or die "unable to load treasurelists\n";
… …
3671 my $face = cf::face::find "sound/$v"; 3677 my $face = cf::face::find "sound/$v";
3672 cf::sound::set $k => $face; 3678 cf::sound::set $k => $face;
3673 } 3679 }
3674} 3680}
3675 3681
3682#d# move docstuff to help or so
3683our %DOCSTRING;
3684
3685sub reload_pod {
3686 trace "loading pods $PODDIR\n";
3687
3688 %DOCSTRING = ();
3689 my @command_list;
3690
3691 for (
3692 [0, "command_help"],
3693 [1, "emote_help"],
3694 [2, "dmcommand_help"],
3695 ) {
3696 my ($type, $path) = @$_;
3697
3698 my $paragraphs = &cf::pod::load_pod ("$PODDIR/$path.pod")
3699 or die "unable to load $path";
3700
3701 my $level = 1e9;
3702 my $rpar;
3703
3704 for my $par (@$paragraphs) {
3705 if ($par->{type} eq "head2") {
3706 # this code taken almost verbatim from DC/Protocol.pm
3707
3708 if ($par->{markup} =~ /^(\S+) (?:\s+ \( ([^\)]*) \) )?/x) {
3709 my $cmd = $1;
3710 my @args = split /\|/, $2;
3711 @args = (".*") unless @args;
3712
3713 $_ = $_ eq ".*" ? "" : " $_"
3714 for @args;
3715
3716 my @variants = map "$cmd$_", sort { (length $a) <=> (length $b) } @args;
3717
3718 $rpar = \($DOCSTRING{"command/$cmd"} = &cf::pod::as_cfpod ([$par]));
3719
3720 push @command_list, [$type, \@variants];
3721 $level = $par->{level};
3722 } else {
3723 error "$par->{markup}: unparsable command heading";
3724 }
3725 } elsif ($par->{level} > $level) {
3726 $$rpar .= &cf::pod::as_cfpod ([$par]);
3727 }
3728
3729 cf::cede_to_tick;
3730 }
3731 }
3732
3733 @command_list = sort {
3734 $a->[0] <=> $b->[0]
3735 or $a->[1] cmp $b->[1]
3736 } @command_list;
3737
3738 cf::cede_to_tick;
3739
3740 add_face "res/command_list" => FT_RSRC,
3741 JSON::XS->new->utf8->encode (\@command_list);
3742}
3743
3676sub reload_resources { 3744sub reload_resources {
3677 trace "reloading resource files...\n"; 3745 trace "reloading resource files...\n";
3678 3746
3679 reload_exp_table;
3680 reload_materials; 3747 reload_materials;
3681 reload_facedata; 3748 reload_facedata;
3749 reload_exp_table;
3682 reload_sound; 3750 reload_sound;
3683 reload_archetypes; 3751 reload_archetypes;
3684 reload_regions; 3752 reload_regions;
3685 reload_treasures; 3753 reload_treasures;
3754 reload_pod;
3686 3755
3687 trace "finished reloading resource files\n"; 3756 trace "finished reloading resource files\n";
3688} 3757}
3689 3758
3690sub reload_config { 3759sub reload_config {
… …
3758 evthread_start IO::AIO::poll_fileno; 3827 evthread_start IO::AIO::poll_fileno;
3759 3828
3760 cf::sync_job { 3829 cf::sync_job {
3761 cf::incloader::init (); 3830 cf::incloader::init ();
3762 3831
3832 db_init;
3833
3763 cf::init_anim; 3834 cf::init_anim;
3764 cf::init_attackmess; 3835 cf::init_attackmess;
3765 cf::init_dynamic; 3836 cf::init_dynamic;
3766 3837
3767 cf::load_settings; 3838 cf::load_settings;
3768 3839
3769 reload_resources; 3840 reload_resources;
3770 reload_config; 3841 reload_config;
3771 db_init;
3772 3842
3773 cf::init_uuid; 3843 cf::init_uuid;
3774 cf::init_signals; 3844 cf::init_signals;
3775 cf::init_skills; 3845 cf::init_skills;
3776 3846
… …
4201 } 4271 }
4202} 4272}
4203 4273
4204{ 4274{
4205 # configure BDB 4275 # configure BDB
4276 info "initialising database";
4206 4277
4207 BDB::min_parallel 16; 4278 BDB::min_parallel 16;
4208 BDB::max_poll_reqs $TICK * 0.1; 4279 BDB::max_poll_reqs $TICK * 0.1;
4209 #$AnyEvent::BDB::WATCHER->priority (1); 4280 #$AnyEvent::BDB::WATCHER->priority (1);
4210 4281
… …
4239 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 4310 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4240 }; 4311 };
4241 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub { 4312 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4242 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 4313 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4243 }; 4314 };
4315
4316 info "database initialised";
4244} 4317}
4245 4318
4246{ 4319{
4247 # configure IO::AIO 4320 # configure IO::AIO
4248 4321
4322 info "initialising aio";
4249 IO::AIO::min_parallel 8; 4323 IO::AIO::min_parallel 8;
4250 IO::AIO::max_poll_time $TICK * 0.1; 4324 IO::AIO::max_poll_time $TICK * 0.1;
4251 undef $AnyEvent::AIO::WATCHER; 4325 undef $AnyEvent::AIO::WATCHER;
4326 info "aio initialised";
4252} 4327}
4253 4328
4254our $_log_backtrace; 4329our $_log_backtrace;
4255our $_log_backtrace_last; 4330our $_log_backtrace_last;
4256 4331

Diff Legend

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