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.479 by root, Thu Oct 8 05:04:27 2009 UTC vs.
Revision 1.497 by root, Fri Dec 18 03:49:46 2009 UTC

1# 1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG. 2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3# 3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5# 5#
6# Deliantra is free software: you can redistribute it and/or modify 6# Deliantra is free software: you can redistribute it and/or modify it under
7# it under the terms of the GNU General Public License as published by 7# the terms of the Affero GNU General Public License as published by the
8# the Free Software Foundation, either version 3 of the License, or 8# Free Software Foundation, either version 3 of the License, or (at your
9# (at your option) any later version. 9# option) any later version.
10# 10#
11# This program is distributed in the hope that it will be useful, 11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of 12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details. 14# GNU General Public License for more details.
15# 15#
16# You should have received a copy of the GNU General Public License 16# You should have received a copy of the Affero GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>. 17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
18# 19#
19# The authors can be reached via e-mail to <support@deliantra.net> 20# The authors can be reached via e-mail to <support@deliantra.net>
20# 21#
21 22
22package cf; 23package cf;
23 24
24use 5.10.0; 25use 5.10.0;
25use utf8; 26use utf8;
… …
31use EV; 32use EV;
32use Opcode; 33use Opcode;
33use Safe; 34use Safe;
34use Safe::Hole; 35use Safe::Hole;
35use Storable (); 36use Storable ();
37use Carp ();
36 38
37use Guard (); 39use Guard ();
38use Coro (); 40use Coro ();
39use Coro::State; 41use Coro::State;
40use Coro::Handle; 42use Coro::Handle;
… …
51use Coro::Util (); 53use Coro::Util ();
52 54
53use JSON::XS 2.01 (); 55use JSON::XS 2.01 ();
54use BDB (); 56use BDB ();
55use Data::Dumper; 57use Data::Dumper;
56use Digest::MD5;
57use Fcntl; 58use Fcntl;
58use YAML (); 59use YAML::XS ();
59use IO::AIO (); 60use IO::AIO ();
60use Time::HiRes; 61use Time::HiRes;
61use Compress::LZF; 62use Compress::LZF;
62use Digest::MD5 (); 63use Digest::MD5 ();
63 64
… …
117our $BDB_DEADLOCK_WATCHER; 118our $BDB_DEADLOCK_WATCHER;
118our $BDB_CHECKPOINT_WATCHER; 119our $BDB_CHECKPOINT_WATCHER;
119our $BDB_TRICKLE_WATCHER; 120our $BDB_TRICKLE_WATCHER;
120our $DB_ENV; 121our $DB_ENV;
121 122
122our @EXTRA_MODULES = qw(pod mapscript); 123our @EXTRA_MODULES = qw(pod match mapscript);
123 124
124our %CFG; 125our %CFG;
125 126
126our $UPTIME; $UPTIME ||= time; 127our $UPTIME; $UPTIME ||= time;
127our $RUNTIME; 128our $RUNTIME;
… …
169for (@REFLECT) { 170for (@REFLECT) {
170 my $reflect = JSON::XS::decode_json $_; 171 my $reflect = JSON::XS::decode_json $_;
171 $REFLECT{$reflect->{class}} = $reflect; 172 $REFLECT{$reflect->{class}} = $reflect;
172} 173}
173 174
175# this is decidedly evil
176$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
177
174############################################################################# 178#############################################################################
175 179
176=head2 GLOBAL VARIABLES 180=head2 GLOBAL VARIABLES
177 181
178=over 4 182=over 4
… …
224returns directly I<after> the tick processing (and consequently, can only wake one process 228returns directly I<after> the tick processing (and consequently, can only wake one process
225per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 229per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
226 230
227=item @cf::INVOKE_RESULTS 231=item @cf::INVOKE_RESULTS
228 232
229This array contains the results of the last C<invoke ()> call. When 233This array contains the results of the last C<invoke ()> call. When
230C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 234C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
231that call. 235that call.
232 236
233=item %cf::REFLECT 237=item %cf::REFLECT
234 238
235Contains, for each (C++) class name, a hash reference with information 239Contains, for each (C++) class name, a hash reference with information
236about object members (methods, scalars and arrays) and other metadata, 240about object members (methods, scalars, arrays and flags) and other
237which is useful for introspection. 241metadata, which is useful for introspection.
238 242
239=back 243=back
240 244
241=cut 245=cut
242 246
… …
285)) { 289)) {
286 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 290 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
287} 291}
288 292
289$EV::DIED = sub { 293$EV::DIED = sub {
290 warn "error in event callback: @_"; 294 Carp::cluck "error in event callback: @_";
291}; 295};
292 296
293############################################################################# 297#############################################################################
294 298
295=head2 UTILITY FUNCTIONS 299=head2 UTILITY FUNCTIONS
… …
2337 : normalise $_ 2341 : normalise $_
2338 } @{ aio_readdir $UNIQUEDIR or [] } 2342 } @{ aio_readdir $UNIQUEDIR or [] }
2339 ] 2343 ]
2340} 2344}
2341 2345
2346=item cf::map::static_maps
2347
2348Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2349file in the shared directory excluding F</styles> and F</editor>). May
2350block.
2351
2352=cut
2353
2354sub static_maps() {
2355 my @dirs = "";
2356 my @maps;
2357
2358 while (@dirs) {
2359 my $dir = shift @dirs;
2360
2361 next if $dir eq "/styles" || $dir eq "/editor";
2362
2363 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2364 or return;
2365
2366 for (@$files) {
2367 s/\.map$// or next;
2368 utf8::decode $_;
2369 push @maps, "$dir/$_";
2370 }
2371
2372 push @dirs, map "$dir/$_", @$dirs;
2373 }
2374
2375 \@maps
2376}
2377
2342=back 2378=back
2343 2379
2344=head3 cf::object 2380=head3 cf::object
2345 2381
2346=cut 2382=cut
… …
2541 ($x, $y) = (-1, -1) 2577 ($x, $y) = (-1, -1)
2542 unless (defined $x) && (defined $y); 2578 unless (defined $x) && (defined $y);
2543 2579
2544 # use -1 or undef as default coordinates, not 0, 0 2580 # use -1 or undef as default coordinates, not 0, 0
2545 ($x, $y) = ($map->enter_x, $map->enter_y) 2581 ($x, $y) = ($map->enter_x, $map->enter_y)
2546 if $x <=0 && $y <= 0; 2582 if $x <= 0 && $y <= 0;
2547 2583
2548 $map->load; 2584 $map->load;
2549 $map->load_neighbours; 2585 $map->load_neighbours;
2550 2586
2551 return unless $self->contr->active; 2587 return unless $self->contr->active;
… …
2750 2786
2751 utf8::encode $text; 2787 utf8::encode $text;
2752 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2788 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2753} 2789}
2754 2790
2791=item $client->send_big_packet ($pkt)
2792
2793Like C<send_packet>, but tries to compress large packets, and fragments
2794them as required.
2795
2796=cut
2797
2798our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2799
2800sub cf::client::send_big_packet {
2801 my ($self, $pkt) = @_;
2802
2803 # try lzf for large packets
2804 $pkt = "lzf " . Compress::LZF::compress $pkt
2805 if 1024 <= length $pkt and $self->{can_lzf};
2806
2807 # split very large packets
2808 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2809 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2810 $pkt = "frag";
2811 }
2812
2813 $self->send_packet ($pkt);
2814}
2815
2755=item $client->send_msg ($channel, $msg, $color, [extra...]) 2816=item $client->send_msg ($channel, $msg, $color, [extra...])
2756 2817
2757Send a drawinfo or msg packet to the client, formatting the msg for the 2818Send a drawinfo or msg packet to the client, formatting the msg for the
2758client if neccessary. C<$type> should be a string identifying the type of 2819client if neccessary. C<$type> should be a string identifying the type of
2759the message, with C<log> being the default. If C<$color> is negative, suppress 2820the message, with C<log> being the default. If C<$color> is negative, suppress
… …
2761 2822
2762=cut 2823=cut
2763 2824
2764# non-persistent channels (usually the info channel) 2825# non-persistent channels (usually the info channel)
2765our %CHANNEL = ( 2826our %CHANNEL = (
2827 "c/motd" => {
2828 id => "infobox",
2829 title => "MOTD",
2830 reply => undef,
2831 tooltip => "The message of the day",
2832 },
2766 "c/identify" => { 2833 "c/identify" => {
2767 id => "infobox", 2834 id => "infobox",
2768 title => "Identify", 2835 title => "Identify",
2769 reply => undef, 2836 reply => undef,
2770 tooltip => "Items recently identified", 2837 tooltip => "Items recently identified",
… …
2772 "c/examine" => { 2839 "c/examine" => {
2773 id => "infobox", 2840 id => "infobox",
2774 title => "Examine", 2841 title => "Examine",
2775 reply => undef, 2842 reply => undef,
2776 tooltip => "Signs and other items you examined", 2843 tooltip => "Signs and other items you examined",
2844 },
2845 "c/shopinfo" => {
2846 id => "infobox",
2847 title => "Shop Info",
2848 reply => undef,
2849 tooltip => "What your bargaining skill tells you about the shop",
2777 }, 2850 },
2778 "c/book" => { 2851 "c/book" => {
2779 id => "infobox", 2852 id => "infobox",
2780 title => "Book", 2853 title => "Book",
2781 reply => undef, 2854 reply => undef,
… …
2897 my $pkt = "msg " 2970 my $pkt = "msg "
2898 . $self->{json_coder}->encode ( 2971 . $self->{json_coder}->encode (
2899 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 2972 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2900 ); 2973 );
2901 2974
2902 # try lzf for large packets
2903 $pkt = "lzf " . Compress::LZF::compress $pkt
2904 if 1024 <= length $pkt and $self->{can_lzf};
2905
2906 # split very large packets
2907 if (8192 < length $pkt and $self->{can_lzf}) {
2908 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2909 $pkt = "frag";
2910 }
2911
2912 $self->send_packet ($pkt); 2975 $self->send_big_packet ($pkt);
2913} 2976}
2914 2977
2915=item $client->ext_msg ($type, @msg) 2978=item $client->ext_msg ($type, @msg)
2916 2979
2917Sends an ext event to the client. 2980Sends an ext event to the client.
… …
2920 2983
2921sub cf::client::ext_msg($$@) { 2984sub cf::client::ext_msg($$@) {
2922 my ($self, $type, @msg) = @_; 2985 my ($self, $type, @msg) = @_;
2923 2986
2924 if ($self->extcmd == 2) { 2987 if ($self->extcmd == 2) {
2925 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 2988 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2926 } elsif ($self->extcmd == 1) { # TODO: remove 2989 } elsif ($self->extcmd == 1) { # TODO: remove
2927 push @msg, msgtype => "event_$type"; 2990 push @msg, msgtype => "event_$type";
2928 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 2991 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2929 } 2992 }
2930} 2993}
2931 2994
2932=item $client->ext_reply ($msgid, @msg) 2995=item $client->ext_reply ($msgid, @msg)
2933 2996
… …
2937 3000
2938sub cf::client::ext_reply($$@) { 3001sub cf::client::ext_reply($$@) {
2939 my ($self, $id, @msg) = @_; 3002 my ($self, $id, @msg) = @_;
2940 3003
2941 if ($self->extcmd == 2) { 3004 if ($self->extcmd == 2) {
2942 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3005 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2943 } elsif ($self->extcmd == 1) { 3006 } elsif ($self->extcmd == 1) {
2944 #TODO: version 1, remove 3007 #TODO: version 1, remove
2945 unshift @msg, msgtype => "reply", msgid => $id; 3008 unshift @msg, msgtype => "reply", msgid => $id;
2946 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3009 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2947 } 3010 }
2948} 3011}
2949 3012
2950=item $success = $client->query ($flags, "text", \&cb) 3013=item $success = $client->query ($flags, "text", \&cb)
2951 3014
… …
3228 while (my ($face, $info) = each %$faces) { 3291 while (my ($face, $info) = each %$faces) {
3229 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3292 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3230 3293
3231 cf::face::set_visibility $idx, $info->{visibility}; 3294 cf::face::set_visibility $idx, $info->{visibility};
3232 cf::face::set_magicmap $idx, $info->{magicmap}; 3295 cf::face::set_magicmap $idx, $info->{magicmap};
3233 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3296 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3234 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3297 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3235 3298
3236 cf::cede_to_tick; 3299 cf::cede_to_tick;
3237 } 3300 }
3238 3301
3239 while (my ($face, $info) = each %$faces) { 3302 while (my ($face, $info) = each %$faces) {
… …
3263 3326
3264 cf::anim::invalidate_all; # d'oh 3327 cf::anim::invalidate_all; # d'oh
3265 } 3328 }
3266 3329
3267 { 3330 {
3268 # TODO: for gcfclient pleasure, we should give resources
3269 # that gcfclient doesn't grok a >10000 face index.
3270 my $res = $facedata->{resource}; 3331 my $res = $facedata->{resource};
3271 3332
3272 while (my ($name, $info) = each %$res) { 3333 while (my ($name, $info) = each %$res) {
3273 if (defined $info->{type}) { 3334 if (defined $info->{type}) {
3274 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3335 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3275 my $data;
3276 3336
3277 if ($info->{type} & 1) { 3337 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3278 # prepend meta info
3279
3280 my $meta = $enc->encode ({
3281 name => $name,
3282 %{ $info->{meta} || {} },
3283 });
3284
3285 $data = pack "(w/a*)*", $meta, $info->{data};
3286 } else {
3287 $data = $info->{data};
3288 }
3289
3290 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3291 cf::face::set_type $idx, $info->{type}; 3338 cf::face::set_type $idx, $info->{type};
3292 } else { 3339 } else {
3293 $RESOURCE{$name} = $info; 3340 $RESOURCE{$name} = $info;
3294 } 3341 }
3295 3342
… …
3379 3426
3380 warn "finished reloading resource files\n"; 3427 warn "finished reloading resource files\n";
3381} 3428}
3382 3429
3383sub reload_config { 3430sub reload_config {
3431 warn "reloading config file...\n";
3432
3384 open my $fh, "<:utf8", "$CONFDIR/config" 3433 open my $fh, "<:utf8", "$CONFDIR/config"
3385 or return; 3434 or return;
3386 3435
3387 local $/; 3436 local $/;
3388 *CFG = YAML::Load <$fh>; 3437 *CFG = YAML::XS::Load scalar <$fh>;
3389 3438
3390 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3439 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3391 3440
3392 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3441 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3393 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3442 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3397 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3446 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3398 and die "WARNING: m(un)lockall failed: $!\n"; 3447 and die "WARNING: m(un)lockall failed: $!\n";
3399 }; 3448 };
3400 warn $@ if $@; 3449 warn $@ if $@;
3401 } 3450 }
3451
3452 warn "finished reloading resource files\n";
3402} 3453}
3403 3454
3404sub pidfile() { 3455sub pidfile() {
3405 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT 3456 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3406 or die "$PIDFILE: $!"; 3457 or die "$PIDFILE: $!";
… …
3454 }; 3505 };
3455 3506
3456 evthread_start IO::AIO::poll_fileno; 3507 evthread_start IO::AIO::poll_fileno;
3457 3508
3458 cf::sync_job { 3509 cf::sync_job {
3510 cf::load_settings;
3511 cf::load_materials;
3512
3459 reload_resources; 3513 reload_resources;
3460 reload_config; 3514 reload_config;
3461 db_init; 3515 db_init;
3462 3516
3463 cf::load_settings;
3464 cf::load_materials;
3465 cf::init_uuid; 3517 cf::init_uuid;
3466 cf::init_signals; 3518 cf::init_signals;
3467 cf::init_commands; 3519 cf::init_commands;
3468 cf::init_skills; 3520 cf::init_skills;
3469 3521
… …
3756 3808
3757 warn "unload completed, starting to reload now"; 3809 warn "unload completed, starting to reload now";
3758 3810
3759 warn "reloading cf.pm"; 3811 warn "reloading cf.pm";
3760 require cf; 3812 require cf;
3761 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3813 cf::_connect_to_perl_1;
3762 3814
3763 warn "loading config and database again"; 3815 warn "loading config and database again";
3764 cf::reload_config; 3816 cf::reload_config;
3765 3817
3766 warn "loading extensions"; 3818 warn "loading extensions";
… …
3828 3880
3829our @WAIT_FOR_TICK; 3881our @WAIT_FOR_TICK;
3830our @WAIT_FOR_TICK_BEGIN; 3882our @WAIT_FOR_TICK_BEGIN;
3831 3883
3832sub wait_for_tick { 3884sub wait_for_tick {
3833 return if tick_inhibit || $Coro::current == $Coro::main; 3885 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3834 3886
3835 my $signal = new Coro::Signal; 3887 my $signal = new Coro::Signal;
3836 push @WAIT_FOR_TICK, $signal; 3888 push @WAIT_FOR_TICK, $signal;
3837 $signal->wait; 3889 $signal->wait;
3838} 3890}
3839 3891
3840sub wait_for_tick_begin { 3892sub wait_for_tick_begin {
3841 return if tick_inhibit || $Coro::current == $Coro::main; 3893 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3842 3894
3843 my $signal = new Coro::Signal; 3895 my $signal = new Coro::Signal;
3844 push @WAIT_FOR_TICK_BEGIN, $signal; 3896 push @WAIT_FOR_TICK_BEGIN, $signal;
3845 $signal->wait; 3897 $signal->wait;
3846} 3898}
… …
3974 } 4026 }
3975} 4027}
3976 4028
3977# load additional modules 4029# load additional modules
3978require "cf/$_.pm" for @EXTRA_MODULES; 4030require "cf/$_.pm" for @EXTRA_MODULES;
4031cf::_connect_to_perl_2;
3979 4032
3980END { cf::emergency_save } 4033END { cf::emergency_save }
3981 4034
39821 40351
3983 4036

Diff Legend

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