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.513 by root, Mon Apr 12 05:22:38 2010 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,2009,2010 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
… …
107our $PIDFILE = "$LOCALDIR/pid"; 108our $PIDFILE = "$LOCALDIR/pid";
108our $RUNTIMEFILE = "$LOCALDIR/runtime"; 109our $RUNTIMEFILE = "$LOCALDIR/runtime";
109 110
110our %RESOURCE; 111our %RESOURCE;
111 112
113our $OUTPUT_RATE_MIN = 4000;
114our $OUTPUT_RATE_MAX = 100000;
115
112our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 116our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
113our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 117our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
114our $NEXT_TICK; 118our $NEXT_TICK;
115our $USE_FSYNC = 1; # use fsync to write maps - default on 119our $USE_FSYNC = 1; # use fsync to write maps - default on
116 120
117our $BDB_DEADLOCK_WATCHER; 121our $BDB_DEADLOCK_WATCHER;
118our $BDB_CHECKPOINT_WATCHER; 122our $BDB_CHECKPOINT_WATCHER;
119our $BDB_TRICKLE_WATCHER; 123our $BDB_TRICKLE_WATCHER;
120our $DB_ENV; 124our $DB_ENV;
121 125
122our @EXTRA_MODULES = qw(pod mapscript); 126our @EXTRA_MODULES = qw(pod match mapscript);
123 127
124our %CFG; 128our %CFG;
125 129
126our $UPTIME; $UPTIME ||= time; 130our $UPTIME; $UPTIME ||= time;
127our $RUNTIME; 131our $RUNTIME;
… …
169for (@REFLECT) { 173for (@REFLECT) {
170 my $reflect = JSON::XS::decode_json $_; 174 my $reflect = JSON::XS::decode_json $_;
171 $REFLECT{$reflect->{class}} = $reflect; 175 $REFLECT{$reflect->{class}} = $reflect;
172} 176}
173 177
178# this is decidedly evil
179$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
180
174############################################################################# 181#############################################################################
175 182
176=head2 GLOBAL VARIABLES 183=head2 GLOBAL VARIABLES
177 184
178=over 4 185=over 4
… …
224returns directly I<after> the tick processing (and consequently, can only wake one process 231returns 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. 232per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
226 233
227=item @cf::INVOKE_RESULTS 234=item @cf::INVOKE_RESULTS
228 235
229This array contains the results of the last C<invoke ()> call. When 236This 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 237C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
231that call. 238that call.
232 239
233=item %cf::REFLECT 240=item %cf::REFLECT
234 241
235Contains, for each (C++) class name, a hash reference with information 242Contains, for each (C++) class name, a hash reference with information
236about object members (methods, scalars and arrays) and other metadata, 243about object members (methods, scalars, arrays and flags) and other
237which is useful for introspection. 244metadata, which is useful for introspection.
238 245
239=back 246=back
240 247
241=cut 248=cut
242 249
… …
285)) { 292)) {
286 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 293 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
287} 294}
288 295
289$EV::DIED = sub { 296$EV::DIED = sub {
290 warn "error in event callback: @_"; 297 Carp::cluck "error in event callback: @_";
291}; 298};
292 299
293############################################################################# 300#############################################################################
294 301
295=head2 UTILITY FUNCTIONS 302=head2 UTILITY FUNCTIONS
… …
419 426
420=cut 427=cut
421 428
422our @SLOT_QUEUE; 429our @SLOT_QUEUE;
423our $SLOT_QUEUE; 430our $SLOT_QUEUE;
431our $SLOT_DECAY = 0.9;
424 432
425$SLOT_QUEUE->cancel if $SLOT_QUEUE; 433$SLOT_QUEUE->cancel if $SLOT_QUEUE;
426$SLOT_QUEUE = Coro::async { 434$SLOT_QUEUE = Coro::async {
427 $Coro::current->desc ("timeslot manager"); 435 $Coro::current->desc ("timeslot manager");
428 436
429 my $signal = new Coro::Signal; 437 my $signal = new Coro::Signal;
438 my $busy;
430 439
431 while () { 440 while () {
432 next_job: 441 next_job:
442
433 my $avail = cf::till_tick; 443 my $avail = cf::till_tick;
434 if ($avail > 0.01) { 444
435 for (0 .. $#SLOT_QUEUE) { 445 for (0 .. $#SLOT_QUEUE) {
436 if ($SLOT_QUEUE[$_][0] < $avail) { 446 if ($SLOT_QUEUE[$_][0] <= $avail) {
447 $busy = 0;
437 my $job = splice @SLOT_QUEUE, $_, 1, (); 448 my $job = splice @SLOT_QUEUE, $_, 1, ();
438 $job->[2]->send; 449 $job->[2]->send;
439 Coro::cede; 450 Coro::cede;
440 goto next_job; 451 goto next_job;
441 } 452 } else {
453 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
442 } 454 }
443 } 455 }
444 456
445 if (@SLOT_QUEUE) { 457 if (@SLOT_QUEUE) {
446 # we do not use wait_for_tick() as it returns immediately when tick is inactive 458 # we do not use wait_for_tick() as it returns immediately when tick is inactive
447 push @cf::WAIT_FOR_TICK, $signal; 459 push @cf::WAIT_FOR_TICK, $signal;
448 $signal->wait; 460 $signal->wait;
449 } else { 461 } else {
462 $busy = 0;
450 Coro::schedule; 463 Coro::schedule;
451 } 464 }
452 } 465 }
453}; 466};
454 467
455sub get_slot($;$$) { 468sub get_slot($;$$) {
456 return if tick_inhibit || $Coro::current == $Coro::main; 469 return if tick_inhibit || $Coro::current == $Coro::main;
457 470
458 my ($time, $pri, $name) = @_; 471 my ($time, $pri, $name) = @_;
459 472
460 $time = $TICK * .6 if $time > $TICK * .6; 473 $time = clamp $time, 0.01, $TICK * .6;
474
461 my $sig = new Coro::Signal; 475 my $sig = new Coro::Signal;
462 476
463 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 477 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
464 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 478 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
465 $SLOT_QUEUE->ready; 479 $SLOT_QUEUE->ready;
… …
492 506
493sub sync_job(&) { 507sub sync_job(&) {
494 my ($job) = @_; 508 my ($job) = @_;
495 509
496 if ($Coro::current == $Coro::main) { 510 if ($Coro::current == $Coro::main) {
497 my $time = EV::time; 511 my $time = AE::time;
498 512
499 # this is the main coro, too bad, we have to block 513 # this is the main coro, too bad, we have to block
500 # till the operation succeeds, freezing the server :/ 514 # till the operation succeeds, freezing the server :/
501 515
502 LOG llevError, Carp::longmess "sync job";#d# 516 LOG llevError, Carp::longmess "sync job";#d#
… …
519 } else { 533 } else {
520 EV::loop EV::LOOP_ONESHOT; 534 EV::loop EV::LOOP_ONESHOT;
521 } 535 }
522 } 536 }
523 537
524 my $time = EV::time - $time; 538 my $time = AE::time - $time;
525 539
526 $TICK_START += $time; # do not account sync jobs to server load 540 $TICK_START += $time; # do not account sync jobs to server load
527 541
528 wantarray ? @res : $res[0] 542 wantarray ? @res : $res[0]
529 } else { 543 } else {
… …
1299} 1313}
1300 1314
1301use File::Glob (); 1315use File::Glob ();
1302 1316
1303cf::player->attach ( 1317cf::player->attach (
1304 on_command => sub { 1318 on_unknown_command => sub {
1305 my ($pl, $name, $params) = @_; 1319 my ($pl, $name, $params) = @_;
1306 1320
1307 my $cb = $COMMAND{$name} 1321 my $cb = $COMMAND{$name}
1308 or return; 1322 or return;
1309 1323
… …
1388 . "\n};\n1"; 1402 . "\n};\n1";
1389 1403
1390 $todo{$base} = \%ext; 1404 $todo{$base} = \%ext;
1391 } 1405 }
1392 1406
1407 my $pass = 0;
1393 my %done; 1408 my %done;
1394 while (%todo) { 1409 while (%todo) {
1395 my $progress; 1410 my $progress;
1396 1411
1412 ++$pass;
1413
1414 ext:
1397 while (my ($k, $v) = each %todo) { 1415 while (my ($k, $v) = each %todo) {
1398 for (split /,\s*/, $v->{meta}{depends}) { 1416 for (split /,\s*/, $v->{meta}{depends}) {
1399 goto skip 1417 next ext
1400 unless exists $done{$_}; 1418 unless exists $done{$_};
1401 } 1419 }
1402 1420
1403 warn "... loading '$k' into '$v->{pkg}'\n"; 1421 warn "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1404 1422
1405 unless (eval $v->{source}) { 1423 my $active = eval $v->{source};
1424
1425 if (length $@) {
1406 my $msg = $@ ? "$v->{path}: $@\n" 1426 warn "$v->{path}: $@\n";
1407 : "$v->{base}: extension inactive.\n";
1408 1427
1409 if (exists $v->{meta}{mandatory}) {
1410 warn $msg;
1411 cf::cleanup "mandatory extension failed to load, exiting."; 1428 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1412 } 1429 if exists $v->{meta}{mandatory};
1413 1430 } else {
1414 warn $msg; 1431 $done{$k} = delete $todo{$k};
1432 push @EXTS, $v->{pkg};
1433 $progress = 1;
1434
1435 warn "$v->{base}: extension inactive.\n"
1436 unless $active;
1415 } 1437 }
1416
1417 $done{$k} = delete $todo{$k};
1418 push @EXTS, $v->{pkg};
1419 $progress = 1;
1420 } 1438 }
1421 1439
1422 skip: 1440 unless ($progress) {
1423 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1441 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1424 unless $progress; 1442
1443 while (my ($k, $v) = each %todo) {
1444 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1445 if exists $v->{meta}{mandatory};
1446 }
1447 }
1425 } 1448 }
1426 }; 1449 };
1427} 1450}
1428 1451
1429############################################################################# 1452#############################################################################
… …
1513 $cf::PLAYER{$login} = $pl 1536 $cf::PLAYER{$login} = $pl
1514 } 1537 }
1515 } 1538 }
1516} 1539}
1517 1540
1541cf::player->attach (
1542 on_load => sub {
1543 my ($pl, $path) = @_;
1544
1545 # restore slots saved in save, below
1546 my $slots = delete $pl->{_slots};
1547
1548 $pl->ob->current_weapon ($slots->[0]);
1549 $pl->combat_ob ($slots->[1]);
1550 $pl->ranged_ob ($slots->[2]);
1551 },
1552);
1553
1518sub save($) { 1554sub save($) {
1519 my ($pl) = @_; 1555 my ($pl) = @_;
1520 1556
1521 return if $pl->{deny_save}; 1557 return if $pl->{deny_save};
1522 1558
… …
1527 1563
1528 aio_mkdir playerdir $pl, 0770; 1564 aio_mkdir playerdir $pl, 0770;
1529 $pl->{last_save} = $cf::RUNTIME; 1565 $pl->{last_save} = $cf::RUNTIME;
1530 1566
1531 cf::get_slot 0.01; 1567 cf::get_slot 0.01;
1568
1569 # save slots, to be restored later
1570 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1532 1571
1533 $pl->save_pl ($path); 1572 $pl->save_pl ($path);
1534 cf::cede_to_tick; 1573 cf::cede_to_tick;
1535} 1574}
1536 1575
… …
1749 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1788 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1750 1789
1751 # mit "rum" bekleckern, nicht 1790 # mit "rum" bekleckern, nicht
1752 $self->_create_random_map ( 1791 $self->_create_random_map (
1753 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1792 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1754 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1793 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1755 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1794 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1756 $rmp->{exit_on_final_map}, 1795 $rmp->{exit_on_final_map},
1757 $rmp->{xsize}, $rmp->{ysize}, 1796 $rmp->{xsize}, $rmp->{ysize},
1758 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1797 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1759 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1798 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
2005 2044
2006 $cf::MAP{$path} = $map 2045 $cf::MAP{$path} = $map
2007 } 2046 }
2008} 2047}
2009 2048
2010sub pre_load { } 2049sub pre_load { }
2011sub post_load { } 2050#sub post_load { } # XS
2012 2051
2013sub load { 2052sub load {
2014 my ($self) = @_; 2053 my ($self) = @_;
2015 2054
2016 local $self->{deny_reset} = 1; # loading can take a long time 2055 local $self->{deny_reset} = 1; # loading can take a long time
… …
2073 } 2112 }
2074 2113
2075 $self->post_load; 2114 $self->post_load;
2076} 2115}
2077 2116
2117# customize the map for a given player, i.e.
2118# return the _real_ map. used by e.g. per-player
2119# maps to change the path to ~playername/mappath
2078sub customise_for { 2120sub customise_for {
2079 my ($self, $ob) = @_; 2121 my ($self, $ob) = @_;
2080 2122
2081 return find "~" . $ob->name . "/" . $self->{path} 2123 return find "~" . $ob->name . "/" . $self->{path}
2082 if $self->per_player; 2124 if $self->per_player;
… …
2337 : normalise $_ 2379 : normalise $_
2338 } @{ aio_readdir $UNIQUEDIR or [] } 2380 } @{ aio_readdir $UNIQUEDIR or [] }
2339 ] 2381 ]
2340} 2382}
2341 2383
2384=item cf::map::static_maps
2385
2386Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2387file in the shared directory excluding F</styles> and F</editor>). May
2388block.
2389
2390=cut
2391
2392sub static_maps() {
2393 my @dirs = "";
2394 my @maps;
2395
2396 while (@dirs) {
2397 my $dir = shift @dirs;
2398
2399 next if $dir eq "/styles" || $dir eq "/editor";
2400
2401 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2402 or return;
2403
2404 for (@$files) {
2405 s/\.map$// or next;
2406 utf8::decode $_;
2407 push @maps, "$dir/$_";
2408 }
2409
2410 push @dirs, map "$dir/$_", @$dirs;
2411 }
2412
2413 \@maps
2414}
2415
2342=back 2416=back
2343 2417
2344=head3 cf::object 2418=head3 cf::object
2345 2419
2346=cut 2420=cut
… …
2541 ($x, $y) = (-1, -1) 2615 ($x, $y) = (-1, -1)
2542 unless (defined $x) && (defined $y); 2616 unless (defined $x) && (defined $y);
2543 2617
2544 # use -1 or undef as default coordinates, not 0, 0 2618 # use -1 or undef as default coordinates, not 0, 0
2545 ($x, $y) = ($map->enter_x, $map->enter_y) 2619 ($x, $y) = ($map->enter_x, $map->enter_y)
2546 if $x <=0 && $y <= 0; 2620 if $x <= 0 && $y <= 0;
2547 2621
2548 $map->load; 2622 $map->load;
2549 $map->load_neighbours; 2623 $map->load_neighbours;
2550 2624
2551 return unless $self->contr->active; 2625 return unless $self->contr->active;
… …
2750 2824
2751 utf8::encode $text; 2825 utf8::encode $text;
2752 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2826 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2753} 2827}
2754 2828
2829=item $client->send_big_packet ($pkt)
2830
2831Like C<send_packet>, but tries to compress large packets, and fragments
2832them as required.
2833
2834=cut
2835
2836our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2837
2838sub cf::client::send_big_packet {
2839 my ($self, $pkt) = @_;
2840
2841 # try lzf for large packets
2842 $pkt = "lzf " . Compress::LZF::compress $pkt
2843 if 1024 <= length $pkt and $self->{can_lzf};
2844
2845 # split very large packets
2846 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2847 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2848 $pkt = "frag";
2849 }
2850
2851 $self->send_packet ($pkt);
2852}
2853
2755=item $client->send_msg ($channel, $msg, $color, [extra...]) 2854=item $client->send_msg ($channel, $msg, $color, [extra...])
2756 2855
2757Send a drawinfo or msg packet to the client, formatting the msg for the 2856Send 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 2857client 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 2858the message, with C<log> being the default. If C<$color> is negative, suppress
… …
2761 2860
2762=cut 2861=cut
2763 2862
2764# non-persistent channels (usually the info channel) 2863# non-persistent channels (usually the info channel)
2765our %CHANNEL = ( 2864our %CHANNEL = (
2865 "c/motd" => {
2866 id => "infobox",
2867 title => "MOTD",
2868 reply => undef,
2869 tooltip => "The message of the day",
2870 },
2766 "c/identify" => { 2871 "c/identify" => {
2767 id => "infobox", 2872 id => "infobox",
2768 title => "Identify", 2873 title => "Identify",
2769 reply => undef, 2874 reply => undef,
2770 tooltip => "Items recently identified", 2875 tooltip => "Items recently identified",
… …
2772 "c/examine" => { 2877 "c/examine" => {
2773 id => "infobox", 2878 id => "infobox",
2774 title => "Examine", 2879 title => "Examine",
2775 reply => undef, 2880 reply => undef,
2776 tooltip => "Signs and other items you examined", 2881 tooltip => "Signs and other items you examined",
2882 },
2883 "c/shopinfo" => {
2884 id => "infobox",
2885 title => "Shop Info",
2886 reply => undef,
2887 tooltip => "What your bargaining skill tells you about the shop",
2777 }, 2888 },
2778 "c/book" => { 2889 "c/book" => {
2779 id => "infobox", 2890 id => "infobox",
2780 title => "Book", 2891 title => "Book",
2781 reply => undef, 2892 reply => undef,
… …
2897 my $pkt = "msg " 3008 my $pkt = "msg "
2898 . $self->{json_coder}->encode ( 3009 . $self->{json_coder}->encode (
2899 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 3010 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2900 ); 3011 );
2901 3012
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); 3013 $self->send_big_packet ($pkt);
2913} 3014}
2914 3015
2915=item $client->ext_msg ($type, @msg) 3016=item $client->ext_msg ($type, @msg)
2916 3017
2917Sends an ext event to the client. 3018Sends an ext event to the client.
… …
2920 3021
2921sub cf::client::ext_msg($$@) { 3022sub cf::client::ext_msg($$@) {
2922 my ($self, $type, @msg) = @_; 3023 my ($self, $type, @msg) = @_;
2923 3024
2924 if ($self->extcmd == 2) { 3025 if ($self->extcmd == 2) {
2925 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3026 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2926 } elsif ($self->extcmd == 1) { # TODO: remove 3027 } elsif ($self->extcmd == 1) { # TODO: remove
2927 push @msg, msgtype => "event_$type"; 3028 push @msg, msgtype => "event_$type";
2928 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3029 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2929 } 3030 }
2930} 3031}
2931 3032
2932=item $client->ext_reply ($msgid, @msg) 3033=item $client->ext_reply ($msgid, @msg)
2933 3034
… …
2937 3038
2938sub cf::client::ext_reply($$@) { 3039sub cf::client::ext_reply($$@) {
2939 my ($self, $id, @msg) = @_; 3040 my ($self, $id, @msg) = @_;
2940 3041
2941 if ($self->extcmd == 2) { 3042 if ($self->extcmd == 2) {
2942 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3043 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2943 } elsif ($self->extcmd == 1) { 3044 } elsif ($self->extcmd == 1) {
2944 #TODO: version 1, remove 3045 #TODO: version 1, remove
2945 unshift @msg, msgtype => "reply", msgid => $id; 3046 unshift @msg, msgtype => "reply", msgid => $id;
2946 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3047 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2947 } 3048 }
2948} 3049}
2949 3050
2950=item $success = $client->query ($flags, "text", \&cb) 3051=item $success = $client->query ($flags, "text", \&cb)
2951 3052
… …
3052 3153
3053 $coro 3154 $coro
3054} 3155}
3055 3156
3056cf::client->attach ( 3157cf::client->attach (
3057 on_destroy => sub { 3158 on_client_destroy => sub {
3058 my ($ns) = @_; 3159 my ($ns) = @_;
3059 3160
3060 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3161 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3061 }, 3162 },
3062); 3163);
… …
3078our $safe_hole = new Safe::Hole; 3179our $safe_hole = new Safe::Hole;
3079 3180
3080$SIG{FPE} = 'IGNORE'; 3181$SIG{FPE} = 'IGNORE';
3081 3182
3082$safe->permit_only (Opcode::opset qw( 3183$safe->permit_only (Opcode::opset qw(
3083 :base_core :base_mem :base_orig :base_math 3184 :base_core :base_mem :base_orig :base_math :base_loop
3084 grepstart grepwhile mapstart mapwhile 3185 grepstart grepwhile mapstart mapwhile
3085 sort time 3186 sort time
3086)); 3187));
3087 3188
3088# here we export the classes and methods available to script code 3189# here we export the classes and methods available to script code
… …
3140 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3241 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3141 $qcode =~ s/\n/\\n/g; 3242 $qcode =~ s/\n/\\n/g;
3142 3243
3143 %vars = (_dummy => 0) unless %vars; 3244 %vars = (_dummy => 0) unless %vars;
3144 3245
3246 my @res;
3145 local $_; 3247 local $_;
3146 local @safe::cf::_safe_eval_args = values %vars;
3147 3248
3148 my $eval = 3249 my $eval =
3149 "do {\n" 3250 "do {\n"
3150 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3251 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3151 . "#line 0 \"{$qcode}\"\n" 3252 . "#line 0 \"{$qcode}\"\n"
3152 . $code 3253 . $code
3153 . "\n}" 3254 . "\n}"
3154 ; 3255 ;
3155 3256
3257 if ($CFG{safe_eval}) {
3156 sub_generation_inc; 3258 sub_generation_inc;
3259 local @safe::cf::_safe_eval_args = values %vars;
3157 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3260 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3158 sub_generation_inc; 3261 sub_generation_inc;
3262 } else {
3263 local @cf::_safe_eval_args = values %vars;
3264 @res = wantarray ? eval eval : scalar eval $eval;
3265 }
3159 3266
3160 if ($@) { 3267 if ($@) {
3161 warn "$@"; 3268 warn "$@";
3162 warn "while executing safe code '$code'\n"; 3269 warn "while executing safe code '$code'\n";
3163 warn "with arguments " . (join " ", %vars) . "\n"; 3270 warn "with arguments " . (join " ", %vars) . "\n";
… …
3182=cut 3289=cut
3183 3290
3184sub register_script_function { 3291sub register_script_function {
3185 my ($fun, $cb) = @_; 3292 my ($fun, $cb) = @_;
3186 3293
3187 no strict 'refs'; 3294 $fun = "safe::$fun" if $CFG{safe_eval};
3188 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3295 *$fun = $safe_hole->wrap ($cb);
3189} 3296}
3190 3297
3191=back 3298=back
3192 3299
3193=cut 3300=cut
… …
3214 3321
3215 $facedata->{version} == 2 3322 $facedata->{version} == 2
3216 or cf::cleanup "$path: version mismatch, cannot proceed."; 3323 or cf::cleanup "$path: version mismatch, cannot proceed.";
3217 3324
3218 # patch in the exptable 3325 # patch in the exptable
3326 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3219 $facedata->{resource}{"res/exp_table"} = { 3327 $facedata->{resource}{"res/exp_table"} = {
3220 type => FT_RSRC, 3328 type => FT_RSRC,
3221 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3329 data => $exp_table,
3330 hash => (Digest::MD5::md5 $exp_table),
3222 }; 3331 };
3223 cf::cede_to_tick; 3332 cf::cede_to_tick;
3224 3333
3225 { 3334 {
3226 my $faces = $facedata->{faceinfo}; 3335 my $faces = $facedata->{faceinfo};
… …
3228 while (my ($face, $info) = each %$faces) { 3337 while (my ($face, $info) = each %$faces) {
3229 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3338 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3230 3339
3231 cf::face::set_visibility $idx, $info->{visibility}; 3340 cf::face::set_visibility $idx, $info->{visibility};
3232 cf::face::set_magicmap $idx, $info->{magicmap}; 3341 cf::face::set_magicmap $idx, $info->{magicmap};
3233 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3342 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3234 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3343 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3235 3344
3236 cf::cede_to_tick; 3345 cf::cede_to_tick;
3237 } 3346 }
3238 3347
3239 while (my ($face, $info) = each %$faces) { 3348 while (my ($face, $info) = each %$faces) {
… …
3263 3372
3264 cf::anim::invalidate_all; # d'oh 3373 cf::anim::invalidate_all; # d'oh
3265 } 3374 }
3266 3375
3267 { 3376 {
3268 # TODO: for gcfclient pleasure, we should give resources
3269 # that gcfclient doesn't grok a >10000 face index.
3270 my $res = $facedata->{resource}; 3377 my $res = $facedata->{resource};
3271 3378
3272 while (my ($name, $info) = each %$res) { 3379 while (my ($name, $info) = each %$res) {
3273 if (defined $info->{type}) { 3380 if (defined $info->{type}) {
3274 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3381 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3275 my $data;
3276 3382
3277 if ($info->{type} & 1) { 3383 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}; 3384 cf::face::set_type $idx, $info->{type};
3292 } else { 3385 } else {
3293 $RESOURCE{$name} = $info; 3386 $RESOURCE{$name} = $info;
3294 } 3387 }
3295 3388
… …
3379 3472
3380 warn "finished reloading resource files\n"; 3473 warn "finished reloading resource files\n";
3381} 3474}
3382 3475
3383sub reload_config { 3476sub reload_config {
3477 warn "reloading config file...\n";
3478
3384 open my $fh, "<:utf8", "$CONFDIR/config" 3479 open my $fh, "<:utf8", "$CONFDIR/config"
3385 or return; 3480 or return;
3386 3481
3387 local $/; 3482 local $/;
3388 *CFG = YAML::Load <$fh>; 3483 *CFG = YAML::XS::Load scalar <$fh>;
3389 3484
3390 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3485 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3391 3486
3392 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3487 $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}; 3488 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3397 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3492 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3398 and die "WARNING: m(un)lockall failed: $!\n"; 3493 and die "WARNING: m(un)lockall failed: $!\n";
3399 }; 3494 };
3400 warn $@ if $@; 3495 warn $@ if $@;
3401 } 3496 }
3497
3498 warn "finished reloading resource files\n";
3402} 3499}
3403 3500
3404sub pidfile() { 3501sub pidfile() {
3405 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT 3502 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3406 or die "$PIDFILE: $!"; 3503 or die "$PIDFILE: $!";
… …
3454 }; 3551 };
3455 3552
3456 evthread_start IO::AIO::poll_fileno; 3553 evthread_start IO::AIO::poll_fileno;
3457 3554
3458 cf::sync_job { 3555 cf::sync_job {
3556 cf::load_settings;
3557 cf::load_materials;
3558
3459 reload_resources; 3559 reload_resources;
3460 reload_config; 3560 reload_config;
3461 db_init; 3561 db_init;
3462 3562
3463 cf::load_settings;
3464 cf::load_materials;
3465 cf::init_uuid; 3563 cf::init_uuid;
3466 cf::init_signals; 3564 cf::init_signals;
3467 cf::init_commands;
3468 cf::init_skills; 3565 cf::init_skills;
3469 3566
3470 cf::init_beforeplay; 3567 cf::init_beforeplay;
3471 3568
3472 atomic; 3569 atomic;
… …
3490 3587
3491# install some emergency cleanup handlers 3588# install some emergency cleanup handlers
3492BEGIN { 3589BEGIN {
3493 our %SIGWATCHER = (); 3590 our %SIGWATCHER = ();
3494 for my $signal (qw(INT HUP TERM)) { 3591 for my $signal (qw(INT HUP TERM)) {
3495 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3592 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3496 cf::cleanup "SIG$signal"; 3593 cf::cleanup "SIG$signal";
3497 }; 3594 };
3498 } 3595 }
3499} 3596}
3500 3597
3501sub write_runtime_sync { 3598sub write_runtime_sync {
3599 my $t0 = AE::time;
3600
3502 # first touch the runtime file to show we are still running: 3601 # first touch the runtime file to show we are still running:
3503 # the fsync below can take a very very long time. 3602 # the fsync below can take a very very long time.
3504 3603
3505 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef; 3604 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3506 3605
3507 my $guard = cf::lock_acquire "write_runtime"; 3606 my $guard = cf::lock_acquire "write_runtime";
3508 3607
3509 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644 3608 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3510 or return; 3609 or return;
3511 3610
3512 my $value = $cf::RUNTIME + 90 + 10; 3611 my $value = $cf::RUNTIME + 90 + 10;
3513 # 10 is the runtime save interval, for a monotonic clock 3612 # 10 is the runtime save interval, for a monotonic clock
3514 # 60 allows for the watchdog to kill the server. 3613 # 60 allows for the watchdog to kill the server.
… …
3527 or return; 3626 or return;
3528 3627
3529 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE 3628 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3530 and return; 3629 and return;
3531 3630
3532 warn "runtime file written.\n"; 3631 warn sprintf "runtime file written (%gs).\n", AE::time - $t0;
3533 3632
3534 1 3633 1
3535} 3634}
3536 3635
3537our $uuid_lock; 3636our $uuid_lock;
… …
3675 return; 3774 return;
3676 } 3775 }
3677 3776
3678 return if $RELOAD++; 3777 return if $RELOAD++;
3679 3778
3680 my $t1 = EV::time; 3779 my $t1 = AE::time;
3681 3780
3682 while ($RELOAD) { 3781 while ($RELOAD) {
3683 warn "reloading..."; 3782 warn "reloading...";
3684 3783
3685 warn "entering sync_job"; 3784 warn "entering sync_job";
… …
3756 3855
3757 warn "unload completed, starting to reload now"; 3856 warn "unload completed, starting to reload now";
3758 3857
3759 warn "reloading cf.pm"; 3858 warn "reloading cf.pm";
3760 require cf; 3859 require cf;
3761 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3860 cf::_connect_to_perl_1;
3762 3861
3763 warn "loading config and database again"; 3862 warn "loading config and database again";
3764 cf::reload_config; 3863 cf::reload_config;
3765 3864
3766 warn "loading extensions"; 3865 warn "loading extensions";
… …
3788 3887
3789 warn "reloaded"; 3888 warn "reloaded";
3790 --$RELOAD; 3889 --$RELOAD;
3791 } 3890 }
3792 3891
3793 $t1 = EV::time - $t1; 3892 $t1 = AE::time - $t1;
3794 warn "reload completed in ${t1}s\n"; 3893 warn "reload completed in ${t1}s\n";
3795}; 3894};
3796 3895
3797our $RELOAD_WATCHER; # used only during reload 3896our $RELOAD_WATCHER; # used only during reload
3798 3897
… …
3801 # coro crashes during coro_state_free->destroy here. 3900 # coro crashes during coro_state_free->destroy here.
3802 3901
3803 $RELOAD_WATCHER ||= cf::async { 3902 $RELOAD_WATCHER ||= cf::async {
3804 Coro::AIO::aio_wait cache_extensions; 3903 Coro::AIO::aio_wait cache_extensions;
3805 3904
3806 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub { 3905 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3807 do_reload_perl; 3906 do_reload_perl;
3808 undef $RELOAD_WATCHER; 3907 undef $RELOAD_WATCHER;
3809 }; 3908 };
3810 }; 3909 };
3811} 3910}
… …
3828 3927
3829our @WAIT_FOR_TICK; 3928our @WAIT_FOR_TICK;
3830our @WAIT_FOR_TICK_BEGIN; 3929our @WAIT_FOR_TICK_BEGIN;
3831 3930
3832sub wait_for_tick { 3931sub wait_for_tick {
3833 return if tick_inhibit || $Coro::current == $Coro::main; 3932 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3834 3933
3835 my $signal = new Coro::Signal; 3934 my $signal = new Coro::Signal;
3836 push @WAIT_FOR_TICK, $signal; 3935 push @WAIT_FOR_TICK, $signal;
3837 $signal->wait; 3936 $signal->wait;
3838} 3937}
3839 3938
3840sub wait_for_tick_begin { 3939sub wait_for_tick_begin {
3841 return if tick_inhibit || $Coro::current == $Coro::main; 3940 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3842 3941
3843 my $signal = new Coro::Signal; 3942 my $signal = new Coro::Signal;
3844 push @WAIT_FOR_TICK_BEGIN, $signal; 3943 push @WAIT_FOR_TICK_BEGIN, $signal;
3845 $signal->wait; 3944 $signal->wait;
3846} 3945}
… …
3851 unless ++$bug_warning > 10; 3950 unless ++$bug_warning > 10;
3852 return; 3951 return;
3853 } 3952 }
3854 3953
3855 cf::server_tick; # one server iteration 3954 cf::server_tick; # one server iteration
3955
3956 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3856 3957
3857 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3958 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3858 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 3959 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3859 Coro::async_pool { 3960 Coro::async_pool {
3860 $Coro::current->{desc} = "runtime saver"; 3961 $Coro::current->{desc} = "runtime saver";
… …
3883} 3984}
3884 3985
3885{ 3986{
3886 # configure BDB 3987 # configure BDB
3887 3988
3888 BDB::min_parallel 8; 3989 BDB::min_parallel 16;
3889 BDB::max_poll_reqs $TICK * 0.1; 3990 BDB::max_poll_reqs $TICK * 0.1;
3890 $AnyEvent::BDB::WATCHER->priority (1); 3991 $AnyEvent::BDB::WATCHER->priority (1);
3891 3992
3892 unless ($DB_ENV) { 3993 unless ($DB_ENV) {
3893 $DB_ENV = BDB::db_env_create; 3994 $DB_ENV = BDB::db_env_create;
… …
3974 } 4075 }
3975} 4076}
3976 4077
3977# load additional modules 4078# load additional modules
3978require "cf/$_.pm" for @EXTRA_MODULES; 4079require "cf/$_.pm" for @EXTRA_MODULES;
4080cf::_connect_to_perl_2;
3979 4081
3980END { cf::emergency_save } 4082END { cf::emergency_save }
3981 4083
39821 40841
3983 4085

Diff Legend

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