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.494 by root, Mon Oct 26 05:18:00 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;
… …
53use JSON::XS 2.01 (); 55use JSON::XS 2.01 ();
54use BDB (); 56use BDB ();
55use Data::Dumper; 57use Data::Dumper;
56use Digest::MD5; 58use Digest::MD5;
57use Fcntl; 59use Fcntl;
58use YAML (); 60use YAML::XS ();
59use IO::AIO (); 61use IO::AIO ();
60use Time::HiRes; 62use Time::HiRes;
61use Compress::LZF; 63use Compress::LZF;
62use Digest::MD5 (); 64use Digest::MD5 ();
63 65
… …
117our $BDB_DEADLOCK_WATCHER; 119our $BDB_DEADLOCK_WATCHER;
118our $BDB_CHECKPOINT_WATCHER; 120our $BDB_CHECKPOINT_WATCHER;
119our $BDB_TRICKLE_WATCHER; 121our $BDB_TRICKLE_WATCHER;
120our $DB_ENV; 122our $DB_ENV;
121 123
122our @EXTRA_MODULES = qw(pod mapscript); 124our @EXTRA_MODULES = qw(pod match mapscript);
123 125
124our %CFG; 126our %CFG;
125 127
126our $UPTIME; $UPTIME ||= time; 128our $UPTIME; $UPTIME ||= time;
127our $RUNTIME; 129our $RUNTIME;
… …
169for (@REFLECT) { 171for (@REFLECT) {
170 my $reflect = JSON::XS::decode_json $_; 172 my $reflect = JSON::XS::decode_json $_;
171 $REFLECT{$reflect->{class}} = $reflect; 173 $REFLECT{$reflect->{class}} = $reflect;
172} 174}
173 175
176# this is decidedly evil
177$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
178
174############################################################################# 179#############################################################################
175 180
176=head2 GLOBAL VARIABLES 181=head2 GLOBAL VARIABLES
177 182
178=over 4 183=over 4
… …
224returns directly I<after> the tick processing (and consequently, can only wake one process 229returns 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. 230per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
226 231
227=item @cf::INVOKE_RESULTS 232=item @cf::INVOKE_RESULTS
228 233
229This array contains the results of the last C<invoke ()> call. When 234This 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 235C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
231that call. 236that call.
232 237
233=item %cf::REFLECT 238=item %cf::REFLECT
234 239
235Contains, for each (C++) class name, a hash reference with information 240Contains, for each (C++) class name, a hash reference with information
236about object members (methods, scalars and arrays) and other metadata, 241about object members (methods, scalars, arrays and flags) and other
237which is useful for introspection. 242metadata, which is useful for introspection.
238 243
239=back 244=back
240 245
241=cut 246=cut
242 247
… …
285)) { 290)) {
286 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 291 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
287} 292}
288 293
289$EV::DIED = sub { 294$EV::DIED = sub {
290 warn "error in event callback: @_"; 295 Carp::cluck "error in event callback: @_";
291}; 296};
292 297
293############################################################################# 298#############################################################################
294 299
295=head2 UTILITY FUNCTIONS 300=head2 UTILITY FUNCTIONS
… …
2337 : normalise $_ 2342 : normalise $_
2338 } @{ aio_readdir $UNIQUEDIR or [] } 2343 } @{ aio_readdir $UNIQUEDIR or [] }
2339 ] 2344 ]
2340} 2345}
2341 2346
2347=item cf::map::static_maps
2348
2349Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2350file in the shared directory excluding F</styles> and F</editor>). May
2351block.
2352
2353=cut
2354
2355sub static_maps() {
2356 my @dirs = "";
2357 my @maps;
2358
2359 while (@dirs) {
2360 my $dir = shift @dirs;
2361
2362 next if $dir eq "/styles" || $dir eq "/editor";
2363
2364 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2365 or return;
2366
2367 for (@$files) {
2368 s/\.map$// or next;
2369 utf8::decode $_;
2370 push @maps, "$dir/$_";
2371 }
2372
2373 push @dirs, map "$dir/$_", @$dirs;
2374 }
2375
2376 \@maps
2377}
2378
2342=back 2379=back
2343 2380
2344=head3 cf::object 2381=head3 cf::object
2345 2382
2346=cut 2383=cut
… …
2541 ($x, $y) = (-1, -1) 2578 ($x, $y) = (-1, -1)
2542 unless (defined $x) && (defined $y); 2579 unless (defined $x) && (defined $y);
2543 2580
2544 # use -1 or undef as default coordinates, not 0, 0 2581 # use -1 or undef as default coordinates, not 0, 0
2545 ($x, $y) = ($map->enter_x, $map->enter_y) 2582 ($x, $y) = ($map->enter_x, $map->enter_y)
2546 if $x <=0 && $y <= 0; 2583 if $x <= 0 && $y <= 0;
2547 2584
2548 $map->load; 2585 $map->load;
2549 $map->load_neighbours; 2586 $map->load_neighbours;
2550 2587
2551 return unless $self->contr->active; 2588 return unless $self->contr->active;
… …
2750 2787
2751 utf8::encode $text; 2788 utf8::encode $text;
2752 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2789 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2753} 2790}
2754 2791
2792=item $client->send_big_packet ($pkt)
2793
2794Like C<send_packet>, but tries to compress large packets, and fragments
2795them as required.
2796
2797=cut
2798
2799our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2800
2801sub cf::client::send_big_packet {
2802 my ($self, $pkt) = @_;
2803
2804 # try lzf for large packets
2805 $pkt = "lzf " . Compress::LZF::compress $pkt
2806 if 1024 <= length $pkt and $self->{can_lzf};
2807
2808 # split very large packets
2809 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2810 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2811 $pkt = "frag";
2812 }
2813
2814 $self->send_packet ($pkt);
2815}
2816
2755=item $client->send_msg ($channel, $msg, $color, [extra...]) 2817=item $client->send_msg ($channel, $msg, $color, [extra...])
2756 2818
2757Send a drawinfo or msg packet to the client, formatting the msg for the 2819Send 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 2820client 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 2821the message, with C<log> being the default. If C<$color> is negative, suppress
… …
2761 2823
2762=cut 2824=cut
2763 2825
2764# non-persistent channels (usually the info channel) 2826# non-persistent channels (usually the info channel)
2765our %CHANNEL = ( 2827our %CHANNEL = (
2828 "c/motd" => {
2829 id => "infobox",
2830 title => "MOTD",
2831 reply => undef,
2832 tooltip => "The message of the day",
2833 },
2766 "c/identify" => { 2834 "c/identify" => {
2767 id => "infobox", 2835 id => "infobox",
2768 title => "Identify", 2836 title => "Identify",
2769 reply => undef, 2837 reply => undef,
2770 tooltip => "Items recently identified", 2838 tooltip => "Items recently identified",
… …
2772 "c/examine" => { 2840 "c/examine" => {
2773 id => "infobox", 2841 id => "infobox",
2774 title => "Examine", 2842 title => "Examine",
2775 reply => undef, 2843 reply => undef,
2776 tooltip => "Signs and other items you examined", 2844 tooltip => "Signs and other items you examined",
2845 },
2846 "c/shopinfo" => {
2847 id => "infobox",
2848 title => "Shop Info",
2849 reply => undef,
2850 tooltip => "What your bargaining skill tells you about the shop",
2777 }, 2851 },
2778 "c/book" => { 2852 "c/book" => {
2779 id => "infobox", 2853 id => "infobox",
2780 title => "Book", 2854 title => "Book",
2781 reply => undef, 2855 reply => undef,
… …
2897 my $pkt = "msg " 2971 my $pkt = "msg "
2898 . $self->{json_coder}->encode ( 2972 . $self->{json_coder}->encode (
2899 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 2973 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2900 ); 2974 );
2901 2975
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); 2976 $self->send_big_packet ($pkt);
2913} 2977}
2914 2978
2915=item $client->ext_msg ($type, @msg) 2979=item $client->ext_msg ($type, @msg)
2916 2980
2917Sends an ext event to the client. 2981Sends an ext event to the client.
… …
2920 2984
2921sub cf::client::ext_msg($$@) { 2985sub cf::client::ext_msg($$@) {
2922 my ($self, $type, @msg) = @_; 2986 my ($self, $type, @msg) = @_;
2923 2987
2924 if ($self->extcmd == 2) { 2988 if ($self->extcmd == 2) {
2925 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 2989 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2926 } elsif ($self->extcmd == 1) { # TODO: remove 2990 } elsif ($self->extcmd == 1) { # TODO: remove
2927 push @msg, msgtype => "event_$type"; 2991 push @msg, msgtype => "event_$type";
2928 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 2992 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2929 } 2993 }
2930} 2994}
2931 2995
2932=item $client->ext_reply ($msgid, @msg) 2996=item $client->ext_reply ($msgid, @msg)
2933 2997
… …
2937 3001
2938sub cf::client::ext_reply($$@) { 3002sub cf::client::ext_reply($$@) {
2939 my ($self, $id, @msg) = @_; 3003 my ($self, $id, @msg) = @_;
2940 3004
2941 if ($self->extcmd == 2) { 3005 if ($self->extcmd == 2) {
2942 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3006 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2943 } elsif ($self->extcmd == 1) { 3007 } elsif ($self->extcmd == 1) {
2944 #TODO: version 1, remove 3008 #TODO: version 1, remove
2945 unshift @msg, msgtype => "reply", msgid => $id; 3009 unshift @msg, msgtype => "reply", msgid => $id;
2946 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3010 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2947 } 3011 }
2948} 3012}
2949 3013
2950=item $success = $client->query ($flags, "text", \&cb) 3014=item $success = $client->query ($flags, "text", \&cb)
2951 3015
… …
3379 3443
3380 warn "finished reloading resource files\n"; 3444 warn "finished reloading resource files\n";
3381} 3445}
3382 3446
3383sub reload_config { 3447sub reload_config {
3448 warn "reloading config file...\n";
3449
3384 open my $fh, "<:utf8", "$CONFDIR/config" 3450 open my $fh, "<:utf8", "$CONFDIR/config"
3385 or return; 3451 or return;
3386 3452
3387 local $/; 3453 local $/;
3388 *CFG = YAML::Load <$fh>; 3454 *CFG = YAML::XS::Load scalar <$fh>;
3389 3455
3390 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3456 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3391 3457
3392 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3458 $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}; 3459 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3397 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3463 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3398 and die "WARNING: m(un)lockall failed: $!\n"; 3464 and die "WARNING: m(un)lockall failed: $!\n";
3399 }; 3465 };
3400 warn $@ if $@; 3466 warn $@ if $@;
3401 } 3467 }
3468
3469 warn "finished reloading resource files\n";
3402} 3470}
3403 3471
3404sub pidfile() { 3472sub pidfile() {
3405 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT 3473 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3406 or die "$PIDFILE: $!"; 3474 or die "$PIDFILE: $!";
… …
3756 3824
3757 warn "unload completed, starting to reload now"; 3825 warn "unload completed, starting to reload now";
3758 3826
3759 warn "reloading cf.pm"; 3827 warn "reloading cf.pm";
3760 require cf; 3828 require cf;
3761 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3829 cf::_connect_to_perl_1;
3762 3830
3763 warn "loading config and database again"; 3831 warn "loading config and database again";
3764 cf::reload_config; 3832 cf::reload_config;
3765 3833
3766 warn "loading extensions"; 3834 warn "loading extensions";
… …
3974 } 4042 }
3975} 4043}
3976 4044
3977# load additional modules 4045# load additional modules
3978require "cf/$_.pm" for @EXTRA_MODULES; 4046require "cf/$_.pm" for @EXTRA_MODULES;
4047cf::_connect_to_perl_2;
3979 4048
3980END { cf::emergency_save } 4049END { cf::emergency_save }
3981 4050
39821 40511
3983 4052

Diff Legend

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