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.100 by root, Mon Dec 25 11:25:49 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#############################################################################
… …
454=cut 555=cut
455 556
456############################################################################# 557#############################################################################
457# object support 558# object support
458 559
560sub reattach {
561 # basically do the same as instantiate, without calling instantiate
562 my ($obj) = @_;
563
564 my $registry = $obj->registry;
565
566 @$registry = ();
567
568 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
569
570 for my $name (keys %{ $obj->{_attachment} || {} }) {
571 if (my $attach = $attachment{$name}) {
572 for (@$attach) {
573 my ($klass, @attach) = @$_;
574 _attach $registry, $klass, @attach;
575 }
576 } else {
577 warn "object uses attachment '$name' that is not available, postponing.\n";
578 }
579 }
580}
581
459cf::attachable->attach ( 582cf::attachable->attach (
460 prio => -1000000, 583 prio => -1000000,
461 on_instantiate => sub { 584 on_instantiate => sub {
462 my ($obj, $data) = @_; 585 my ($obj, $data) = @_;
463 586
… …
467 my ($name, $args) = @$_; 590 my ($name, $args) = @$_;
468 591
469 $obj->attach ($name, %{$args || {} }); 592 $obj->attach ($name, %{$args || {} });
470 } 593 }
471 }, 594 },
472 on_reattach => sub { 595 on_reattach => \&reattach,
473 # basically do the same as instantiate, without calling instantiate
474 my ($obj) = @_;
475 my $registry = $obj->registry;
476
477 @$registry = ();
478
479 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
480
481 for my $name (keys %{ $obj->{_attachment} || {} }) {
482 if (my $attach = $attachment{$name}) {
483 for (@$attach) {
484 my ($klass, @attach) = @$_;
485 _attach $registry, $klass, @attach;
486 }
487 } else {
488 warn "object uses attachment '$name' that is not available, postponing.\n";
489 }
490 }
491 },
492 on_clone => sub { 596 on_clone => sub {
493 my ($src, $dst) = @_; 597 my ($src, $dst) = @_;
494 598
495 @{$dst->registry} = @{$src->registry}; 599 @{$dst->registry} = @{$src->registry};
496 600
… …
502); 606);
503 607
504sub object_freezer_save { 608sub object_freezer_save {
505 my ($filename, $rdata, $objs) = @_; 609 my ($filename, $rdata, $objs) = @_;
506 610
611 sync_job {
507 if (length $$rdata) { 612 if (length $$rdata) {
508 warn sprintf "saving %s (%d,%d)\n", 613 warn sprintf "saving %s (%d,%d)\n",
509 $filename, length $$rdata, scalar @$objs; 614 $filename, length $$rdata, scalar @$objs;
510 615
511 if (open my $fh, ">:raw", "$filename~") { 616 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
512 chmod SAVE_MODE, $fh;
513 syswrite $fh, $$rdata;
514 close $fh;
515
516 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
517 chmod SAVE_MODE, $fh; 617 chmod SAVE_MODE, $fh;
518 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 618 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
619 aio_fsync $fh;
519 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;
520 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;
521 } else { 636 } else {
522 unlink "$filename.pst"; 637 warn "FATAL: $filename~: $!\n";
523 } 638 }
524
525 rename "$filename~", $filename;
526 } else { 639 } else {
527 warn "FATAL: $filename~: $!\n";
528 }
529 } else {
530 unlink $filename; 640 aio_unlink $filename;
531 unlink "$filename.pst"; 641 aio_unlink "$filename.pst";
642 }
532 } 643 }
533} 644}
534 645
535sub object_freezer_as_string { 646sub object_freezer_as_string {
536 my ($rdata, $objs) = @_; 647 my ($rdata, $objs) = @_;
… …
541} 652}
542 653
543sub object_thawer_load { 654sub object_thawer_load {
544 my ($filename) = @_; 655 my ($filename) = @_;
545 656
546 local $/; 657 my ($data, $av);
547 658
548 my $av; 659 (aio_load $filename, $data) >= 0
660 or return;
549 661
550 #TODO: use sysread etc. 662 unless (aio_stat "$filename.pst") {
551 if (open my $data, "<:raw:perlio", $filename) { 663 (aio_load "$filename.pst", $av) >= 0
552 $data = <$data>; 664 or return;
553 if (open my $pst, "<:raw:perlio", "$filename.pst") {
554 $av = eval { (Storable::thaw <$pst>)->{objs} }; 665 $av = eval { (Storable::thaw <$av>)->{objs} };
555 } 666 }
667
556 return ($data, $av); 668 return ($data, $av);
557 }
558
559 ()
560} 669}
561 670
562############################################################################# 671#############################################################################
563# command handling &c 672# command handling &c
564 673
… …
913 my $coro; $coro = async { 1022 my $coro; $coro = async {
914 eval { 1023 eval {
915 $cb->(); 1024 $cb->();
916 }; 1025 };
917 warn $@ if $@; 1026 warn $@ if $@;
1027 };
1028
1029 $coro->on_destroy (sub {
918 delete $self->{_coro}{$coro+0}; 1030 delete $self->{_coro}{$coro+0};
919 }; 1031 });
920 1032
921 $self->{_coro}{$coro+0} = $coro; 1033 $self->{_coro}{$coro+0} = $coro;
1034
1035 $coro
922} 1036}
923 1037
924cf::client->attach ( 1038cf::client->attach (
925 on_destroy => sub { 1039 on_destroy => sub {
926 my ($ns) = @_; 1040 my ($ns) = @_;
… …
1167} 1281}
1168 1282
1169############################################################################# 1283#############################################################################
1170# initialisation 1284# initialisation
1171 1285
1172sub _perl_reload(&) { 1286sub _perl_reload() {
1173 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 }
1174 1292
1175 $msg->("reloading..."); 1293 warn "reloading...";
1294
1295 local $FREEZE = 1;
1296 cf::emergency_save;
1176 1297
1177 eval { 1298 eval {
1299 # if anything goes wrong in here, we should simply crash as we already saved
1300
1178 # cancel all watchers 1301 # cancel all watchers
1179 for (Event::all_watchers) { 1302 for (Event::all_watchers) {
1180 $_->cancel if $_->data & WF_AUTOCANCEL; 1303 $_->cancel if $_->data & WF_AUTOCANCEL;
1181 } 1304 }
1182 1305
1306 # cancel all extension coros
1307 $_->cancel for values %EXT_CORO;
1308 %EXT_CORO = ();
1309
1183 # unload all extensions 1310 # unload all extensions
1184 for (@exts) { 1311 for (@exts) {
1185 $msg->("unloading <$_>"); 1312 warn "unloading <$_>";
1186 unload_extension $_; 1313 unload_extension $_;
1187 } 1314 }
1188 1315
1189 # unload all modules loaded from $LIBDIR 1316 # unload all modules loaded from $LIBDIR
1190 while (my ($k, $v) = each %INC) { 1317 while (my ($k, $v) = each %INC) {
1191 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 1318 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1192 1319
1193 $msg->("removing <$k>"); 1320 warn "removing <$k>";
1194 delete $INC{$k}; 1321 delete $INC{$k};
1195 1322
1196 $k =~ s/\.pm$//; 1323 $k =~ s/\.pm$//;
1197 $k =~ s/\//::/g; 1324 $k =~ s/\//::/g;
1198 1325
… …
1203 Symbol::delete_package $k; 1330 Symbol::delete_package $k;
1204 } 1331 }
1205 1332
1206 # sync database to disk 1333 # sync database to disk
1207 cf::db_sync; 1334 cf::db_sync;
1335 IO::AIO::flush;
1208 1336
1209 # get rid of safe::, as good as possible 1337 # get rid of safe::, as good as possible
1210 Symbol::delete_package "safe::$_" 1338 Symbol::delete_package "safe::$_"
1211 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);
1212 1340
1213 # remove register_script_function callbacks 1341 # remove register_script_function callbacks
1214 # TODO 1342 # TODO
1215 1343
1216 # unload cf.pm "a bit" 1344 # unload cf.pm "a bit"
… …
1219 # don't, removes xs symbols, too, 1347 # don't, removes xs symbols, too,
1220 # and global variables created in xs 1348 # and global variables created in xs
1221 #Symbol::delete_package __PACKAGE__; 1349 #Symbol::delete_package __PACKAGE__;
1222 1350
1223 # reload cf.pm 1351 # reload cf.pm
1224 $msg->("reloading cf.pm"); 1352 warn "reloading cf.pm";
1225 require cf; 1353 require cf;
1226 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 1354 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1227
1228 1355
1229 # load config and database again 1356 # load config and database again
1230 cf::cfg_load; 1357 cf::cfg_load;
1231 cf::db_load; 1358 cf::db_load;
1232 1359
1233 # load extensions 1360 # load extensions
1234 $msg->("load extensions"); 1361 warn "load extensions";
1235 cf::load_extensions; 1362 cf::load_extensions;
1236 1363
1237 # reattach attachments to objects 1364 # reattach attachments to objects
1238 $msg->("reattach"); 1365 warn "reattach";
1239 _global_reattach; 1366 _global_reattach;
1240 }; 1367 };
1241 $msg->($@) if $@;
1242 1368
1243 $msg->("reloaded"); 1369 if ($@) {
1370 warn $@;
1371 warn "error while reloading, exiting.";
1372 exit 1;
1373 }
1374
1375 warn "reloaded successfully";
1244}; 1376};
1245 1377
1246sub perl_reload() { 1378sub perl_reload() {
1247 _perl_reload { 1379 _perl_reload;
1248 warn $_[0];
1249 print "$_[0]\n";
1250 };
1251} 1380}
1252 1381
1253register "<global>", __PACKAGE__; 1382register "<global>", __PACKAGE__;
1254 1383
1255register_command "perl-reload" => sub { 1384register_command "perl-reload" => sub {
1256 my ($who, $arg) = @_; 1385 my ($who, $arg) = @_;
1257 1386
1258 if ($who->flag (FLAG_WIZ)) { 1387 if ($who->flag (FLAG_WIZ)) {
1388 $who->message ("reloading...");
1259 _perl_reload { 1389 _perl_reload;
1260 warn $_[0];
1261 $who->message ($_[0]);
1262 };
1263 } 1390 }
1264}; 1391};
1265 1392
1266unshift @INC, $LIBDIR; 1393unshift @INC, $LIBDIR;
1267 1394
1268$TICK_WATCHER = Event->timer ( 1395$TICK_WATCHER = Event->timer (
1396 reentrant => 0,
1269 prio => 0, 1397 prio => 0,
1270 at => $NEXT_TICK || 1, 1398 at => $NEXT_TICK || $TICK,
1271 data => WF_AUTOCANCEL, 1399 data => WF_AUTOCANCEL,
1272 cb => sub { 1400 cb => sub {
1401 unless ($FREEZE) {
1273 cf::server_tick; # one server iteration 1402 cf::server_tick; # one server iteration
1403 $RUNTIME += $TICK;
1404 }
1274 1405
1275 my $NOW = Event::time;
1276 $NEXT_TICK += $TICK; 1406 $NEXT_TICK += $TICK;
1277 1407
1278 # 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
1279 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1409 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
1280 1410
1281 $TICK_WATCHER->at ($NEXT_TICK); 1411 $TICK_WATCHER->at ($NEXT_TICK);
1282 $TICK_WATCHER->start; 1412 $TICK_WATCHER->start;
1283 }, 1413 },
1284); 1414);
… …
1289 poll => 'r', 1419 poll => 'r',
1290 prio => 5, 1420 prio => 5,
1291 data => WF_AUTOCANCEL, 1421 data => WF_AUTOCANCEL,
1292 cb => \&IO::AIO::poll_cb); 1422 cb => \&IO::AIO::poll_cb);
1293 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
12941 14331
1295 1434

Diff Legend

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