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.96 by root, Fri Dec 22 06:02:29 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;
18
19use IO::AIO; 18use Coro::AIO;
19
20use Fcntl;
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 = ();
34our %EXTCMD = (); 36our %EXTCMD = ();
35 37
36_init_vars;
37
38our @EVENT; 38our @EVENT;
39our $LIBDIR = datadir . "/ext"; 39our $LIBDIR = datadir . "/ext";
40 40
41our $TICK = MAX_TIME * 1e-6; 41our $TICK = MAX_TIME * 1e-6;
42our $TICK_WATCHER; 42our $TICK_WATCHER;
43our $NEXT_TICK; 43our $NEXT_TICK;
44our $NOW;
44 45
45our %CFG; 46our %CFG;
46 47
47our $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;
48 71
49############################################################################# 72#############################################################################
50 73
51=head2 GLOBAL VARIABLES 74=head2 GLOBAL VARIABLES
52 75
53=over 4 76=over 4
54 77
55=item $cf::UPTIME 78=item $cf::UPTIME
56 79
57The 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.
58 86
59=item $cf::LIBDIR 87=item $cf::LIBDIR
60 88
61The perl library directory, where extensions and cf-specific modules can 89The perl library directory, where extensions and cf-specific modules can
62be 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.
63 95
64=item $cf::TICK 96=item $cf::TICK
65 97
66The interval between server ticks, in seconds. 98The interval between server ticks, in seconds.
67 99
… …
75=cut 107=cut
76 108
77BEGIN { 109BEGIN {
78 *CORE::GLOBAL::warn = sub { 110 *CORE::GLOBAL::warn = sub {
79 my $msg = join "", @_; 111 my $msg = join "", @_;
112 utf8::encode $msg;
113
80 $msg .= "\n" 114 $msg .= "\n"
81 unless $msg =~ /\n$/; 115 unless $msg =~ /\n$/;
82 116
83 print STDERR "cfperl: $msg";
84 LOG llevError, "cfperl: $msg"; 117 LOG llevError, "cfperl: $msg";
85 }; 118 };
86} 119}
87 120
88@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 121@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
… …
93@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 126@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
94 127
95# we bless all objects into (empty) derived classes to force a method lookup 128# we bless all objects into (empty) derived classes to force a method lookup
96# within the Safe compartment. 129# within the Safe compartment.
97for my $pkg (qw( 130for my $pkg (qw(
98 cf::global 131 cf::global cf::attachable
99 cf::object cf::object::player 132 cf::object cf::object::player
100 cf::client cf::player 133 cf::client cf::player
101 cf::arch cf::living 134 cf::arch cf::living
102 cf::map cf::party cf::region 135 cf::map cf::party cf::region
103)) { 136)) {
… …
139=cut 172=cut
140 173
141sub to_json($) { 174sub to_json($) {
142 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 175 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
143 JSON::Syck::Dump $_[0] 176 JSON::Syck::Dump $_[0]
177}
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
144} 243}
145 244
146=back 245=back
147 246
148=cut 247=cut
… …
269exception. 368exception.
270 369
271=cut 370=cut
272 371
273# the following variables are defined in .xs and must not be re-created 372# the following variables are defined in .xs and must not be re-created
274our @CB_GLOBAL = (); # registry for all global events 373our @CB_GLOBAL = (); # registry for all global events
374our @CB_ATTACHABLE = (); # registry for all attachables
275our @CB_OBJECT = (); # all objects (should not be used except in emergency) 375our @CB_OBJECT = (); # all objects (should not be used except in emergency)
276our @CB_PLAYER = (); 376our @CB_PLAYER = ();
277our @CB_CLIENT = (); 377our @CB_CLIENT = ();
278our @CB_TYPE = (); # registry for type (cf-object class) based events 378our @CB_TYPE = (); # registry for type (cf-object class) based events
279our @CB_MAP = (); 379our @CB_MAP = ();
280 380
281my %attachment; 381my %attachment;
282 382
283sub _attach_cb($$$$) { 383sub _attach_cb($$$$) {
284 my ($registry, $event, $prio, $cb) = @_; 384 my ($registry, $event, $prio, $cb) = @_;
… …
289 389
290 @{$registry->[$event]} = sort 390 @{$registry->[$event]} = sort
291 { $a->[0] cmp $b->[0] } 391 { $a->[0] cmp $b->[0] }
292 @{$registry->[$event] || []}, $cb; 392 @{$registry->[$event] || []}, $cb;
293} 393}
394
395# hack
396my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
294 397
295# attach handles attaching event callbacks 398# attach handles attaching event callbacks
296# the only thing the caller has to do is pass the correct 399# the only thing the caller has to do is pass the correct
297# registry (== where the callback attaches to). 400# registry (== where the callback attaches to).
298sub _attach { 401sub _attach {
… …
300 403
301 my $object_type; 404 my $object_type;
302 my $prio = 0; 405 my $prio = 0;
303 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; 406 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
304 407
408 #TODO: get rid of this hack
409 if ($attachable_klass{$klass}) {
410 %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
411 }
412
305 while (@arg) { 413 while (@arg) {
306 my $type = shift @arg; 414 my $type = shift @arg;
307 415
308 if ($type eq "prio") { 416 if ($type eq "prio") {
309 $prio = shift @arg; 417 $prio = shift @arg;
… …
384 my ($obj, $name) = @_; 492 my ($obj, $name) = @_;
385 493
386 exists $obj->{_attachment}{$name} 494 exists $obj->{_attachment}{$name}
387} 495}
388 496
389for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) { 497for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
390 eval "#line " . __LINE__ . " 'cf.pm' 498 eval "#line " . __LINE__ . " 'cf.pm'
391 sub cf::\L$klass\E::_attach_registry { 499 sub cf::\L$klass\E::_attach_registry {
392 (\\\@CB_$klass, KLASS_$klass) 500 (\\\@CB_$klass, KLASS_$klass)
393 } 501 }
394 502
… …
447=cut 555=cut
448 556
449############################################################################# 557#############################################################################
450# object support 558# object support
451 559
452sub instantiate {
453 my ($obj, $data) = @_;
454
455 $data = from_json $data;
456
457 for (@$data) {
458 my ($name, $args) = @$_;
459
460 $obj->attach ($name, %{$args || {} });
461 }
462}
463
464# basically do the same as instantiate, without calling instantiate
465sub reattach { 560sub reattach {
561 # basically do the same as instantiate, without calling instantiate
466 my ($obj) = @_; 562 my ($obj) = @_;
563
467 my $registry = $obj->registry; 564 my $registry = $obj->registry;
468 565
469 @$registry = (); 566 @$registry = ();
470 567
471 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} }; 568 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
… …
480 warn "object uses attachment '$name' that is not available, postponing.\n"; 577 warn "object uses attachment '$name' that is not available, postponing.\n";
481 } 578 }
482 } 579 }
483} 580}
484 581
485sub object_freezer_save { 582cf::attachable->attach (
486 my ($filename, $rdata, $objs) = @_;
487
488 if (length $$rdata) {
489 warn sprintf "saving %s (%d,%d)\n",
490 $filename, length $$rdata, scalar @$objs;
491
492 if (open my $fh, ">:raw", "$filename~") {
493 chmod SAVE_MODE, $fh;
494 syswrite $fh, $$rdata;
495 close $fh;
496
497 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
498 chmod SAVE_MODE, $fh;
499 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
500 close $fh;
501 rename "$filename.pst~", "$filename.pst";
502 } else {
503 unlink "$filename.pst";
504 }
505
506 rename "$filename~", $filename;
507 } else {
508 warn "FATAL: $filename~: $!\n";
509 }
510 } else {
511 unlink $filename;
512 unlink "$filename.pst";
513 }
514}
515
516sub object_freezer_as_string {
517 my ($rdata, $objs) = @_;
518
519 use Data::Dumper;
520
521 $$rdata . Dumper $objs
522}
523
524sub object_thawer_load {
525 my ($filename) = @_;
526
527 local $/;
528
529 my $av;
530
531 #TODO: use sysread etc.
532 if (open my $data, "<:raw:perlio", $filename) {
533 $data = <$data>;
534 if (open my $pst, "<:raw:perlio", "$filename.pst") {
535 $av = eval { (Storable::thaw <$pst>)->{objs} };
536 }
537 return ($data, $av);
538 }
539
540 ()
541}
542
543cf::object->attach (
544 prio => -1000000, 583 prio => -1000000,
584 on_instantiate => sub {
585 my ($obj, $data) = @_;
586
587 $data = from_json $data;
588
589 for (@$data) {
590 my ($name, $args) = @$_;
591
592 $obj->attach ($name, %{$args || {} });
593 }
594 },
595 on_reattach => \&reattach,
545 on_clone => sub { 596 on_clone => sub {
546 my ($src, $dst) = @_; 597 my ($src, $dst) = @_;
547 598
548 @{$dst->registry} = @{$src->registry}; 599 @{$dst->registry} = @{$src->registry};
549 600
… …
551 602
552 %{$dst->{_attachment}} = %{$src->{_attachment}} 603 %{$dst->{_attachment}} = %{$src->{_attachment}}
553 if exists $src->{_attachment}; 604 if exists $src->{_attachment};
554 }, 605 },
555); 606);
607
608sub object_freezer_save {
609 my ($filename, $rdata, $objs) = @_;
610
611 sync_job {
612 if (length $$rdata) {
613 warn sprintf "saving %s (%d,%d)\n",
614 $filename, length $$rdata, scalar @$objs;
615
616 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
617 chmod SAVE_MODE, $fh;
618 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
619 aio_fsync $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;
629 aio_rename "$filename.pst~", "$filename.pst";
630 }
631 } else {
632 aio_unlink "$filename.pst";
633 }
634
635 aio_rename "$filename~", $filename;
636 } else {
637 warn "FATAL: $filename~: $!\n";
638 }
639 } else {
640 aio_unlink $filename;
641 aio_unlink "$filename.pst";
642 }
643 }
644}
645
646sub object_freezer_as_string {
647 my ($rdata, $objs) = @_;
648
649 use Data::Dumper;
650
651 $$rdata . Dumper $objs
652}
653
654sub object_thawer_load {
655 my ($filename) = @_;
656
657 my ($data, $av);
658
659 (aio_load $filename, $data) >= 0
660 or return;
661
662 unless (aio_stat "$filename.pst") {
663 (aio_load "$filename.pst", $av) >= 0
664 or return;
665 $av = eval { (Storable::thaw <$av>)->{objs} };
666 }
667
668 return ($data, $av);
669}
556 670
557############################################################################# 671#############################################################################
558# command handling &c 672# command handling &c
559 673
560=item cf::register_command $name => \&callback($ob,$args); 674=item cf::register_command $name => \&callback($ob,$args);
… …
886 1000
887 if (@{ $ns->{query_queue} } == @$queue) { 1001 if (@{ $ns->{query_queue} } == @$queue) {
888 if (@$queue) { 1002 if (@$queue) {
889 $ns->send_packet ($ns->{query_queue}[0][0]); 1003 $ns->send_packet ($ns->{query_queue}[0][0]);
890 } else { 1004 } else {
891 $ns->state (ST_PLAYING); 1005 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
892 } 1006 }
893 } 1007 }
894 }, 1008 },
895); 1009);
896 1010
… …
908 my $coro; $coro = async { 1022 my $coro; $coro = async {
909 eval { 1023 eval {
910 $cb->(); 1024 $cb->();
911 }; 1025 };
912 warn $@ if $@; 1026 warn $@ if $@;
913 warn "cancel myself\n";#d# 1027 };
1028
1029 $coro->on_destroy (sub {
914 delete $self->{_coro}{$coro+0}; 1030 delete $self->{_coro}{$coro+0};
915 }; 1031 });
916 1032
917 $self->{_coro}{$coro+0} = $coro; 1033 $self->{_coro}{$coro+0} = $coro;
1034
1035 $coro
918} 1036}
919 1037
920cf::client->attach ( 1038cf::client->attach (
921 on_destroy => sub { 1039 on_destroy => sub {
922 my ($ns) = @_; 1040 my ($ns) = @_;
923 1041
924 warn "cancel $_" for values %{ $ns->{_coro} || {} };#d#
925 $_->cancel for values %{ $ns->{_coro} || {} }; 1042 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
926 }, 1043 },
927); 1044);
928 1045
929=back 1046=back
930 1047
… …
1164} 1281}
1165 1282
1166############################################################################# 1283#############################################################################
1167# initialisation 1284# initialisation
1168 1285
1169sub _perl_reload(&) { 1286sub _perl_reload() {
1170 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 }
1171 1292
1172 $msg->("reloading..."); 1293 warn "reloading...";
1294
1295 local $FREEZE = 1;
1296 cf::emergency_save;
1173 1297
1174 eval { 1298 eval {
1299 # if anything goes wrong in here, we should simply crash as we already saved
1300
1175 # cancel all watchers 1301 # cancel all watchers
1176 for (Event::all_watchers) { 1302 for (Event::all_watchers) {
1177 $_->cancel if $_->data & WF_AUTOCANCEL; 1303 $_->cancel if $_->data & WF_AUTOCANCEL;
1178 } 1304 }
1179 1305
1306 # cancel all extension coros
1307 $_->cancel for values %EXT_CORO;
1308 %EXT_CORO = ();
1309
1180 # unload all extensions 1310 # unload all extensions
1181 for (@exts) { 1311 for (@exts) {
1182 $msg->("unloading <$_>"); 1312 warn "unloading <$_>";
1183 unload_extension $_; 1313 unload_extension $_;
1184 } 1314 }
1185 1315
1186 # unload all modules loaded from $LIBDIR 1316 # unload all modules loaded from $LIBDIR
1187 while (my ($k, $v) = each %INC) { 1317 while (my ($k, $v) = each %INC) {
1188 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 1318 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1189 1319
1190 $msg->("removing <$k>"); 1320 warn "removing <$k>";
1191 delete $INC{$k}; 1321 delete $INC{$k};
1192 1322
1193 $k =~ s/\.pm$//; 1323 $k =~ s/\.pm$//;
1194 $k =~ s/\//::/g; 1324 $k =~ s/\//::/g;
1195 1325
… …
1200 Symbol::delete_package $k; 1330 Symbol::delete_package $k;
1201 } 1331 }
1202 1332
1203 # sync database to disk 1333 # sync database to disk
1204 cf::db_sync; 1334 cf::db_sync;
1335 IO::AIO::flush;
1205 1336
1206 # get rid of safe::, as good as possible 1337 # get rid of safe::, as good as possible
1207 Symbol::delete_package "safe::$_" 1338 Symbol::delete_package "safe::$_"
1208 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);
1209 1340
1210 # remove register_script_function callbacks 1341 # remove register_script_function callbacks
1211 # TODO 1342 # TODO
1212 1343
1213 # unload cf.pm "a bit" 1344 # unload cf.pm "a bit"
… …
1216 # don't, removes xs symbols, too, 1347 # don't, removes xs symbols, too,
1217 # and global variables created in xs 1348 # and global variables created in xs
1218 #Symbol::delete_package __PACKAGE__; 1349 #Symbol::delete_package __PACKAGE__;
1219 1350
1220 # reload cf.pm 1351 # reload cf.pm
1221 $msg->("reloading cf.pm"); 1352 warn "reloading cf.pm";
1222 require cf; 1353 require cf;
1354 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1223 1355
1224 # load config and database again 1356 # load config and database again
1225 cf::cfg_load; 1357 cf::cfg_load;
1226 cf::db_load; 1358 cf::db_load;
1227 1359
1228 # load extensions 1360 # load extensions
1229 $msg->("load extensions"); 1361 warn "load extensions";
1230 cf::load_extensions; 1362 cf::load_extensions;
1231 1363
1232 # reattach attachments to objects 1364 # reattach attachments to objects
1233 $msg->("reattach"); 1365 warn "reattach";
1234 _global_reattach; 1366 _global_reattach;
1235 }; 1367 };
1236 $msg->($@) if $@;
1237 1368
1238 $msg->("reloaded"); 1369 if ($@) {
1370 warn $@;
1371 warn "error while reloading, exiting.";
1372 exit 1;
1373 }
1374
1375 warn "reloaded successfully";
1239}; 1376};
1240 1377
1241sub perl_reload() { 1378sub perl_reload() {
1242 _perl_reload { 1379 _perl_reload;
1243 warn $_[0];
1244 print "$_[0]\n";
1245 };
1246} 1380}
1247 1381
1248register "<global>", __PACKAGE__; 1382register "<global>", __PACKAGE__;
1249 1383
1250register_command "perl-reload" => sub { 1384register_command "perl-reload" => sub {
1251 my ($who, $arg) = @_; 1385 my ($who, $arg) = @_;
1252 1386
1253 if ($who->flag (FLAG_WIZ)) { 1387 if ($who->flag (FLAG_WIZ)) {
1388 $who->message ("reloading...");
1254 _perl_reload { 1389 _perl_reload;
1255 warn $_[0];
1256 $who->message ($_[0]);
1257 };
1258 } 1390 }
1259}; 1391};
1260 1392
1261unshift @INC, $LIBDIR; 1393unshift @INC, $LIBDIR;
1262 1394
1263$TICK_WATCHER = Event->timer ( 1395$TICK_WATCHER = Event->timer (
1396 reentrant => 0,
1264 prio => 0, 1397 prio => 0,
1265 at => $NEXT_TICK || 1, 1398 at => $NEXT_TICK || $TICK,
1266 data => WF_AUTOCANCEL, 1399 data => WF_AUTOCANCEL,
1267 cb => sub { 1400 cb => sub {
1401 unless ($FREEZE) {
1268 cf::server_tick; # one server iteration 1402 cf::server_tick; # one server iteration
1403 $RUNTIME += $TICK;
1404 }
1269 1405
1270 my $NOW = Event::time;
1271 $NEXT_TICK += $TICK; 1406 $NEXT_TICK += $TICK;
1272 1407
1273 # 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
1274 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1409 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
1275 1410
1276 $TICK_WATCHER->at ($NEXT_TICK); 1411 $TICK_WATCHER->at ($NEXT_TICK);
1277 $TICK_WATCHER->start; 1412 $TICK_WATCHER->start;
1278 }, 1413 },
1279); 1414);
… …
1284 poll => 'r', 1419 poll => 'r',
1285 prio => 5, 1420 prio => 5,
1286 data => WF_AUTOCANCEL, 1421 data => WF_AUTOCANCEL,
1287 cb => \&IO::AIO::poll_cb); 1422 cb => \&IO::AIO::poll_cb);
1288 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
12891 14331
1290 1434

Diff Legend

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