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.102 by root, Wed Dec 27 15:20:54 2006 UTC vs.
Revision 1.106 by root, Sun Dec 31 17:29:22 2006 UTC

… …
8use Storable; 8use Storable;
9use Opcode; 9use Opcode;
10use Safe; 10use Safe;
11use Safe::Hole; 11use Safe::Hole;
12 12
13use Coro; 13use Coro 3.3;
14use Coro::Event; 14use Coro::Event;
15use Coro::Timer; 15use Coro::Timer;
16use Coro::Signal; 16use Coro::Signal;
17use Coro::Semaphore; 17use Coro::Semaphore;
18use Coro::AIO;
18 19
20use Fcntl;
19use IO::AIO 2.3; 21use IO::AIO 2.31 ();
20use YAML::Syck (); 22use YAML::Syck ();
21use Time::HiRes; 23use Time::HiRes;
22 24
23use Event; $Event::Eval = 1; # no idea why this is required, but it is 25use Event; $Event::Eval = 1; # no idea why this is required, but it is
24 26
25# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 27# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
26$YAML::Syck::ImplicitUnicode = 1; 28$YAML::Syck::ImplicitUnicode = 1;
27 29
28$Coro::main->prio (Coro::PRIO_MIN); 30$Coro::main->prio (2); # run main coroutine ("the server") with very high priority
29 31
30sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 32sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
31 33
32our %COMMAND = (); 34our %COMMAND = ();
33our %COMMAND_TIME = (); 35our %COMMAND_TIME = ();
… …
37our $LIBDIR = datadir . "/ext"; 39our $LIBDIR = datadir . "/ext";
38 40
39our $TICK = MAX_TIME * 1e-6; 41our $TICK = MAX_TIME * 1e-6;
40our $TICK_WATCHER; 42our $TICK_WATCHER;
41our $NEXT_TICK; 43our $NEXT_TICK;
44our $NOW;
42 45
43our %CFG; 46our %CFG;
44 47
45our $UPTIME; $UPTIME ||= time; 48our $UPTIME; $UPTIME ||= time;
49our $RUNTIME;
50
51our %MAP; # all maps
52our $LINK_MAP; # the special {link} map
53our $FREEZE;
54
55binmode STDOUT;
56binmode STDERR;
57
58# read virtual server time, if available
59unless ($RUNTIME || !-e cf::localdir . "/runtime") {
60 open my $fh, "<", cf::localdir . "/runtime"
61 or die "unable to read runtime file: $!";
62 $RUNTIME = <$fh> + 0.;
63}
64
65mkdir cf::localdir;
66mkdir cf::localdir . "/" . cf::playerdir;
67mkdir cf::localdir . "/" . cf::tmpdir;
68mkdir cf::localdir . "/" . cf::uniquedir;
69
70our %EXT_CORO;
46 71
47############################################################################# 72#############################################################################
48 73
49=head2 GLOBAL VARIABLES 74=head2 GLOBAL VARIABLES
50 75
51=over 4 76=over 4
52 77
53=item $cf::UPTIME 78=item $cf::UPTIME
54 79
55The timestamp of the server start (so not actually an uptime). 80The timestamp of the server start (so not actually an uptime).
81
82=item $cf::RUNTIME
83
84The time this server has run, starts at 0 and is increased by $cf::TICK on
85every server tick.
56 86
57=item $cf::LIBDIR 87=item $cf::LIBDIR
58 88
59The perl library directory, where extensions and cf-specific modules can 89The perl library directory, where extensions and cf-specific modules can
60be found. It will be added to C<@INC> automatically. 90be found. It will be added to C<@INC> automatically.
91
92=item $cf::NOW
93
94The time of the last (current) server tick.
61 95
62=item $cf::TICK 96=item $cf::TICK
63 97
64The interval between server ticks, in seconds. 98The interval between server ticks, in seconds.
65 99
… …
73=cut 107=cut
74 108
75BEGIN { 109BEGIN {
76 *CORE::GLOBAL::warn = sub { 110 *CORE::GLOBAL::warn = sub {
77 my $msg = join "", @_; 111 my $msg = join "", @_;
112 utf8::encode $msg;
113
78 $msg .= "\n" 114 $msg .= "\n"
79 unless $msg =~ /\n$/; 115 unless $msg =~ /\n$/;
80 116
81 print STDERR "cfperl: $msg";
82 LOG llevError, "cfperl: $msg"; 117 LOG llevError, "cfperl: $msg";
83 }; 118 };
84} 119}
85 120
86@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 121@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
… …
139sub to_json($) { 174sub to_json($) {
140 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 175 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
141 JSON::Syck::Dump $_[0] 176 JSON::Syck::Dump $_[0]
142} 177}
143 178
179=item cf::sync_job { BLOCK }
180
181The design of crossfire+ requires that the main coro ($Coro::main) is
182always able to handle events or runnable, as crossfire+ is only partly
183reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.
184
185If it must be done, put the blocking parts into C<sync_job>. This will run
186the given BLOCK in another coroutine while waiting for the result. The
187server will be frozen during this time, so the block should either finish
188fast or be very important.
189
190=cut
191
192sub sync_job(&) {
193 my ($job) = @_;
194
195 my $busy = 1;
196 my @res;
197
198 # TODO: use suspend/resume instead
199 local $FREEZE = 1;
200
201 my $coro = Coro::async {
202 @res = eval { $job->() };
203 warn $@ if $@;
204 undef $busy;
205 };
206
207 if ($Coro::current == $Coro::main) {
208 $coro->prio (Coro::PRIO_MAX);
209 while ($busy) {
210 Coro::cede_notself;
211 Event::one_event unless Coro::nready;
212 }
213 } else {
214 $coro->join;
215 }
216
217 wantarray ? @res : $res[0]
218}
219
220=item $coro = cf::coro { BLOCK }
221
222Creates and returns a new coro. This coro is automcatially being canceled
223when the extension calling this is being unloaded.
224
225=cut
226
227sub coro(&) {
228 my $cb = shift;
229
230 my $coro; $coro = async {
231 eval {
232 $cb->();
233 };
234 warn $@ if $@;
235 };
236
237 $coro->on_destroy (sub {
238 delete $EXT_CORO{$coro+0};
239 });
240 $EXT_CORO{$coro+0} = $coro;
241
242 $coro
243}
244
144=back 245=back
145 246
146=cut 247=cut
147 248
148############################################################################# 249#############################################################################
… …
505); 606);
506 607
507sub object_freezer_save { 608sub object_freezer_save {
508 my ($filename, $rdata, $objs) = @_; 609 my ($filename, $rdata, $objs) = @_;
509 610
611 sync_job {
510 if (length $$rdata) { 612 if (length $$rdata) {
511 warn sprintf "saving %s (%d,%d)\n", 613 warn sprintf "saving %s (%d,%d)\n",
512 $filename, length $$rdata, scalar @$objs; 614 $filename, length $$rdata, scalar @$objs;
513 615
514 if (open my $fh, ">:raw", "$filename~") { 616 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
515 chmod SAVE_MODE, $fh;
516 syswrite $fh, $$rdata;
517 close $fh;
518
519 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
520 chmod SAVE_MODE, $fh; 617 chmod SAVE_MODE, $fh;
521 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 618 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
619 aio_fsync $fh;
522 close $fh; 620 close $fh;
621
622 if (@$objs) {
623 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
624 chmod SAVE_MODE, $fh;
625 my $data = Storable::nfreeze { version => 1, objs => $objs };
626 aio_write $fh, 0, (length $data), $data, 0;
627 aio_fsync $fh;
628 close $fh;
523 rename "$filename.pst~", "$filename.pst"; 629 aio_rename "$filename.pst~", "$filename.pst";
630 }
631 } else {
632 aio_unlink "$filename.pst";
633 }
634
635 aio_rename "$filename~", $filename;
524 } else { 636 } else {
525 unlink "$filename.pst"; 637 warn "FATAL: $filename~: $!\n";
526 } 638 }
527
528 rename "$filename~", $filename;
529 } else { 639 } else {
530 warn "FATAL: $filename~: $!\n";
531 }
532 } else {
533 unlink $filename; 640 aio_unlink $filename;
534 unlink "$filename.pst"; 641 aio_unlink "$filename.pst";
642 }
535 } 643 }
536} 644}
537 645
538sub object_freezer_as_string { 646sub object_freezer_as_string {
539 my ($rdata, $objs) = @_; 647 my ($rdata, $objs) = @_;
… …
544} 652}
545 653
546sub object_thawer_load { 654sub object_thawer_load {
547 my ($filename) = @_; 655 my ($filename) = @_;
548 656
549 local $/; 657 my ($data, $av);
550 658
551 my $av; 659 (aio_load $filename, $data) >= 0
660 or return;
552 661
553 #TODO: use sysread etc. 662 unless (aio_stat "$filename.pst") {
554 if (open my $data, "<:raw:perlio", $filename) { 663 (aio_load "$filename.pst", $av) >= 0
555 $data = <$data>; 664 or return;
556 if (open my $pst, "<:raw:perlio", "$filename.pst") {
557 $av = eval { (Storable::thaw <$pst>)->{objs} }; 665 $av = eval { (Storable::thaw <$av>)->{objs} };
558 } 666 }
667
559 return ($data, $av); 668 return ($data, $av);
560 }
561
562 ()
563} 669}
564 670
565############################################################################# 671#############################################################################
566# command handling &c 672# command handling &c
567 673
… …
916 my $coro; $coro = async { 1022 my $coro; $coro = async {
917 eval { 1023 eval {
918 $cb->(); 1024 $cb->();
919 }; 1025 };
920 warn $@ if $@; 1026 warn $@ if $@;
1027 };
1028
1029 $coro->on_destroy (sub {
921 delete $self->{_coro}{$coro+0}; 1030 delete $self->{_coro}{$coro+0};
922 }; 1031 });
923 1032
924 $self->{_coro}{$coro+0} = $coro; 1033 $self->{_coro}{$coro+0} = $coro;
1034
1035 $coro
925} 1036}
926 1037
927cf::client->attach ( 1038cf::client->attach (
928 on_destroy => sub { 1039 on_destroy => sub {
929 my ($ns) = @_; 1040 my ($ns) = @_;
… …
1170} 1281}
1171 1282
1172############################################################################# 1283#############################################################################
1173# initialisation 1284# initialisation
1174 1285
1175sub _perl_reload(&) { 1286sub _perl_reload() {
1176 my ($msg) = @_; 1287 # can/must only be called in main
1288 if ($Coro::current != $Coro::main) {
1289 warn "can only reload from main coroutine\n";
1290 return;
1291 }
1177 1292
1178 $msg->("reloading..."); 1293 warn "reloading...";
1294
1295 local $FREEZE = 1;
1296 cf::emergency_save;
1179 1297
1180 eval { 1298 eval {
1299 # if anything goes wrong in here, we should simply crash as we already saved
1300
1181 # cancel all watchers 1301 # cancel all watchers
1182 for (Event::all_watchers) { 1302 for (Event::all_watchers) {
1183 $_->cancel if $_->data & WF_AUTOCANCEL; 1303 $_->cancel if $_->data & WF_AUTOCANCEL;
1184 } 1304 }
1185 1305
1306 # cancel all extension coros
1307 $_->cancel for values %EXT_CORO;
1308 %EXT_CORO = ();
1309
1186 # unload all extensions 1310 # unload all extensions
1187 for (@exts) { 1311 for (@exts) {
1188 $msg->("unloading <$_>"); 1312 warn "unloading <$_>";
1189 unload_extension $_; 1313 unload_extension $_;
1190 } 1314 }
1191 1315
1192 # unload all modules loaded from $LIBDIR 1316 # unload all modules loaded from $LIBDIR
1193 while (my ($k, $v) = each %INC) { 1317 while (my ($k, $v) = each %INC) {
1194 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 1318 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1195 1319
1196 $msg->("removing <$k>"); 1320 warn "removing <$k>";
1197 delete $INC{$k}; 1321 delete $INC{$k};
1198 1322
1199 $k =~ s/\.pm$//; 1323 $k =~ s/\.pm$//;
1200 $k =~ s/\//::/g; 1324 $k =~ s/\//::/g;
1201 1325
… …
1206 Symbol::delete_package $k; 1330 Symbol::delete_package $k;
1207 } 1331 }
1208 1332
1209 # sync database to disk 1333 # sync database to disk
1210 cf::db_sync; 1334 cf::db_sync;
1335 IO::AIO::flush;
1211 1336
1212 # get rid of safe::, as good as possible 1337 # get rid of safe::, as good as possible
1213 Symbol::delete_package "safe::$_" 1338 Symbol::delete_package "safe::$_"
1214 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region); 1339 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1215 1340
1216 # remove register_script_function callbacks 1341 # remove register_script_function callbacks
1217 # TODO 1342 # TODO
1218 1343
1219 # unload cf.pm "a bit" 1344 # unload cf.pm "a bit"
… …
1222 # don't, removes xs symbols, too, 1347 # don't, removes xs symbols, too,
1223 # and global variables created in xs 1348 # and global variables created in xs
1224 #Symbol::delete_package __PACKAGE__; 1349 #Symbol::delete_package __PACKAGE__;
1225 1350
1226 # reload cf.pm 1351 # reload cf.pm
1227 $msg->("reloading cf.pm"); 1352 warn "reloading cf.pm";
1228 require cf; 1353 require cf;
1229 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 1354 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1230 1355
1231 # load config and database again 1356 # load config and database again
1232 cf::cfg_load; 1357 cf::cfg_load;
1233 cf::db_load; 1358 cf::db_load;
1234 1359
1235 # load extensions 1360 # load extensions
1236 $msg->("load extensions"); 1361 warn "load extensions";
1237 cf::load_extensions; 1362 cf::load_extensions;
1238 1363
1239 # reattach attachments to objects 1364 # reattach attachments to objects
1240 $msg->("reattach"); 1365 warn "reattach";
1241 _global_reattach; 1366 _global_reattach;
1242 }; 1367 };
1243 $msg->($@) if $@;
1244 1368
1245 $msg->("reloaded"); 1369 if ($@) {
1370 warn $@;
1371 warn "error while reloading, exiting.";
1372 exit 1;
1373 }
1374
1375 warn "reloaded successfully";
1246}; 1376};
1247 1377
1248sub perl_reload() { 1378sub perl_reload() {
1249 _perl_reload { 1379 _perl_reload;
1250 warn $_[0];
1251 print "$_[0]\n";
1252 };
1253} 1380}
1254 1381
1255register "<global>", __PACKAGE__; 1382register "<global>", __PACKAGE__;
1256 1383
1257register_command "perl-reload" => sub { 1384register_command "perl-reload" => sub {
1258 my ($who, $arg) = @_; 1385 my ($who, $arg) = @_;
1259 1386
1260 if ($who->flag (FLAG_WIZ)) { 1387 if ($who->flag (FLAG_WIZ)) {
1388 $who->message ("reloading...");
1261 _perl_reload { 1389 _perl_reload;
1262 warn $_[0];
1263 $who->message ($_[0]);
1264 };
1265 } 1390 }
1266}; 1391};
1267 1392
1268unshift @INC, $LIBDIR; 1393unshift @INC, $LIBDIR;
1269 1394
1270$TICK_WATCHER = Event->timer ( 1395$TICK_WATCHER = Event->timer (
1396 reentrant => 0,
1271 prio => 0, 1397 prio => 0,
1272 at => $NEXT_TICK || 1, 1398 at => $NEXT_TICK || $TICK,
1273 data => WF_AUTOCANCEL, 1399 data => WF_AUTOCANCEL,
1274 cb => sub { 1400 cb => sub {
1401 unless ($FREEZE) {
1275 cf::server_tick; # one server iteration 1402 cf::server_tick; # one server iteration
1403 $RUNTIME += $TICK;
1404 }
1276 1405
1277 my $NOW = Event::time;
1278 $NEXT_TICK += $TICK; 1406 $NEXT_TICK += $TICK;
1279 1407
1280 # if we are delayed by four ticks or more, skip them all 1408 # if we are delayed by four ticks or more, skip them all
1281 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1409 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
1282 1410
1283 $TICK_WATCHER->at ($NEXT_TICK); 1411 $TICK_WATCHER->at ($NEXT_TICK);
1284 $TICK_WATCHER->start; 1412 $TICK_WATCHER->start;
1285 }, 1413 },
1286); 1414);
… …
1291 poll => 'r', 1419 poll => 'r',
1292 prio => 5, 1420 prio => 5,
1293 data => WF_AUTOCANCEL, 1421 data => WF_AUTOCANCEL,
1294 cb => \&IO::AIO::poll_cb); 1422 cb => \&IO::AIO::poll_cb);
1295 1423
1424# we must not ever block the main coroutine
1425$Coro::idle = sub {
1426 #Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#
1427 warn "FATAL: Coro::idle was called, major BUG\n";
1428 (Coro::unblock_sub {
1429 Event::one_event;
1430 })->();
1431};
1432
12961 14331
1297 1434

Diff Legend

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