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.95 by root, Fri Dec 22 02:04:20 2006 UTC vs.
Revision 1.106 by root, Sun Dec 31 17:29:22 2006 UTC

1package cf; 1package cf;
2
3use utf8;
4use strict;
2 5
3use Symbol; 6use Symbol;
4use List::Util; 7use List::Util;
5use Storable; 8use Storable;
6use Opcode; 9use Opcode;
7use Safe; 10use Safe;
8use Safe::Hole; 11use Safe::Hole;
9 12
13use Coro 3.3;
14use Coro::Event;
15use Coro::Timer;
16use Coro::Signal;
17use Coro::Semaphore;
18use Coro::AIO;
19
20use Fcntl;
10use IO::AIO (); 21use IO::AIO 2.31 ();
11use YAML::Syck (); 22use YAML::Syck ();
12use Time::HiRes; 23use Time::HiRes;
13use Event; 24
14$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
15 26
16# 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?
17$YAML::Syck::ImplicitUnicode = 1; 28$YAML::Syck::ImplicitUnicode = 1;
18 29
19use strict; 30$Coro::main->prio (2); # run main coroutine ("the server") with very high priority
20 31
21sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 32sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
22 33
23our %COMMAND = (); 34our %COMMAND = ();
24our %COMMAND_TIME = (); 35our %COMMAND_TIME = ();
25our %EXTCMD = (); 36our %EXTCMD = ();
26 37
27_init_vars;
28
29our @EVENT; 38our @EVENT;
30our $LIBDIR = datadir . "/ext"; 39our $LIBDIR = datadir . "/ext";
31 40
32our $TICK = MAX_TIME * 1e-6; 41our $TICK = MAX_TIME * 1e-6;
33our $TICK_WATCHER; 42our $TICK_WATCHER;
34our $NEXT_TICK; 43our $NEXT_TICK;
44our $NOW;
35 45
36our %CFG; 46our %CFG;
37 47
38our $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;
39 71
40############################################################################# 72#############################################################################
41 73
42=head2 GLOBAL VARIABLES 74=head2 GLOBAL VARIABLES
43 75
44=over 4 76=over 4
45 77
46=item $cf::UPTIME 78=item $cf::UPTIME
47 79
48The 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.
49 86
50=item $cf::LIBDIR 87=item $cf::LIBDIR
51 88
52The perl library directory, where extensions and cf-specific modules can 89The perl library directory, where extensions and cf-specific modules can
53be 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.
54 95
55=item $cf::TICK 96=item $cf::TICK
56 97
57The interval between server ticks, in seconds. 98The interval between server ticks, in seconds.
58 99
… …
66=cut 107=cut
67 108
68BEGIN { 109BEGIN {
69 *CORE::GLOBAL::warn = sub { 110 *CORE::GLOBAL::warn = sub {
70 my $msg = join "", @_; 111 my $msg = join "", @_;
112 utf8::encode $msg;
113
71 $msg .= "\n" 114 $msg .= "\n"
72 unless $msg =~ /\n$/; 115 unless $msg =~ /\n$/;
73 116
74 print STDERR "cfperl: $msg";
75 LOG llevError, "cfperl: $msg"; 117 LOG llevError, "cfperl: $msg";
76 }; 118 };
77} 119}
78 120
79@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 121@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
… …
84@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 126@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
85 127
86# 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
87# within the Safe compartment. 129# within the Safe compartment.
88for my $pkg (qw( 130for my $pkg (qw(
89 cf::global 131 cf::global cf::attachable
90 cf::object cf::object::player 132 cf::object cf::object::player
91 cf::client cf::player 133 cf::client cf::player
92 cf::arch cf::living 134 cf::arch cf::living
93 cf::map cf::party cf::region 135 cf::map cf::party cf::region
94)) { 136)) {
… …
130=cut 172=cut
131 173
132sub to_json($) { 174sub to_json($) {
133 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 175 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
134 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
135} 243}
136 244
137=back 245=back
138 246
139=cut 247=cut
… …
249 my ($self, $victim) = @_; 357 my ($self, $victim) = @_;
250 ... 358 ...
251 } 359 }
252 } 360 }
253 361
362=item $attachable->valid
363
364Just because you have a perl object does not mean that the corresponding
365C-level object still exists. If you try to access an object that has no
366valid C counterpart anymore you get an exception at runtime. This method
367can be used to test for existence of the C object part without causing an
368exception.
369
254=cut 370=cut
255 371
256# 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
257our @CB_GLOBAL = (); # registry for all global events 373our @CB_GLOBAL = (); # registry for all global events
374our @CB_ATTACHABLE = (); # registry for all attachables
258our @CB_OBJECT = (); # all objects (should not be used except in emergency) 375our @CB_OBJECT = (); # all objects (should not be used except in emergency)
259our @CB_PLAYER = (); 376our @CB_PLAYER = ();
260our @CB_CLIENT = (); 377our @CB_CLIENT = ();
261our @CB_TYPE = (); # registry for type (cf-object class) based events 378our @CB_TYPE = (); # registry for type (cf-object class) based events
262our @CB_MAP = (); 379our @CB_MAP = ();
263 380
264my %attachment; 381my %attachment;
265 382
266sub _attach_cb($$$$) { 383sub _attach_cb($$$$) {
267 my ($registry, $event, $prio, $cb) = @_; 384 my ($registry, $event, $prio, $cb) = @_;
… …
272 389
273 @{$registry->[$event]} = sort 390 @{$registry->[$event]} = sort
274 { $a->[0] cmp $b->[0] } 391 { $a->[0] cmp $b->[0] }
275 @{$registry->[$event] || []}, $cb; 392 @{$registry->[$event] || []}, $cb;
276} 393}
394
395# hack
396my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
277 397
278# attach handles attaching event callbacks 398# attach handles attaching event callbacks
279# 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
280# registry (== where the callback attaches to). 400# registry (== where the callback attaches to).
281sub _attach { 401sub _attach {
… …
283 403
284 my $object_type; 404 my $object_type;
285 my $prio = 0; 405 my $prio = 0;
286 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;
287 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
288 while (@arg) { 413 while (@arg) {
289 my $type = shift @arg; 414 my $type = shift @arg;
290 415
291 if ($type eq "prio") { 416 if ($type eq "prio") {
292 $prio = shift @arg; 417 $prio = shift @arg;
… …
367 my ($obj, $name) = @_; 492 my ($obj, $name) = @_;
368 493
369 exists $obj->{_attachment}{$name} 494 exists $obj->{_attachment}{$name}
370} 495}
371 496
372for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) { 497for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
373 eval "#line " . __LINE__ . " 'cf.pm' 498 eval "#line " . __LINE__ . " 'cf.pm'
374 sub cf::\L$klass\E::_attach_registry { 499 sub cf::\L$klass\E::_attach_registry {
375 (\\\@CB_$klass, KLASS_$klass) 500 (\\\@CB_$klass, KLASS_$klass)
376 } 501 }
377 502
… …
413 } 538 }
414 539
415 0 540 0
416} 541}
417 542
418=item $bool = cf::invoke EVENT_GLOBAL_XXX, ... 543=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)
419 544
420=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
421
422=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
423
424=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...) 545=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
425 546
426=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
427
428Generate a global/object/player/map-specific event with the given arguments. 547Generate an object-specific event with the given arguments.
429 548
430This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be 549This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
431removed in future versions), and there is no public API to access override 550removed in future versions), and there is no public API to access override
432results (if you must, access C<@cf::invoke_results> directly). 551results (if you must, access C<@cf::invoke_results> directly).
433 552
434=back 553=back
435 554
436=cut 555=cut
437 556
438############################################################################# 557#############################################################################
439
440=head2 METHODS VALID FOR ALL ATTACHABLE OBJECTS
441
442Attachable objects includes objects, players, clients and maps.
443
444=over 4
445
446=item $object->valid
447
448Just because you have a perl object does not mean that the corresponding
449C-level object still exists. If you try to access an object that has no
450valid C counterpart anymore you get an exception at runtime. This method
451can be used to test for existence of the C object part without causing an
452exception.
453
454=back
455
456=cut
457
458#############################################################################
459# object support 558# object support
460 559
461sub instantiate {
462 my ($obj, $data) = @_;
463
464 $data = from_json $data;
465
466 for (@$data) {
467 my ($name, $args) = @$_;
468
469 $obj->attach ($name, %{$args || {} });
470 }
471}
472
473# basically do the same as instantiate, without calling instantiate
474sub reattach { 560sub reattach {
561 # basically do the same as instantiate, without calling instantiate
475 my ($obj) = @_; 562 my ($obj) = @_;
563
476 my $registry = $obj->registry; 564 my $registry = $obj->registry;
477 565
478 @$registry = (); 566 @$registry = ();
479 567
480 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} }; 568 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
… …
489 warn "object uses attachment '$name' that is not available, postponing.\n"; 577 warn "object uses attachment '$name' that is not available, postponing.\n";
490 } 578 }
491 } 579 }
492} 580}
493 581
494sub object_freezer_save { 582cf::attachable->attach (
495 my ($filename, $rdata, $objs) = @_;
496
497 if (length $$rdata) {
498 warn sprintf "saving %s (%d,%d)\n",
499 $filename, length $$rdata, scalar @$objs;
500
501 if (open my $fh, ">:raw", "$filename~") {
502 chmod SAVE_MODE, $fh;
503 syswrite $fh, $$rdata;
504 close $fh;
505
506 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
507 chmod SAVE_MODE, $fh;
508 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
509 close $fh;
510 rename "$filename.pst~", "$filename.pst";
511 } else {
512 unlink "$filename.pst";
513 }
514
515 rename "$filename~", $filename;
516 } else {
517 warn "FATAL: $filename~: $!\n";
518 }
519 } else {
520 unlink $filename;
521 unlink "$filename.pst";
522 }
523}
524
525sub object_freezer_as_string {
526 my ($rdata, $objs) = @_;
527
528 use Data::Dumper;
529
530 $$rdata . Dumper $objs
531}
532
533sub object_thawer_load {
534 my ($filename) = @_;
535
536 local $/;
537
538 my $av;
539
540 #TODO: use sysread etc.
541 if (open my $data, "<:raw:perlio", $filename) {
542 $data = <$data>;
543 if (open my $pst, "<:raw:perlio", "$filename.pst") {
544 $av = eval { (Storable::thaw <$pst>)->{objs} };
545 }
546 return ($data, $av);
547 }
548
549 ()
550}
551
552cf::object->attach (
553 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,
554 on_clone => sub { 596 on_clone => sub {
555 my ($src, $dst) = @_; 597 my ($src, $dst) = @_;
556 598
557 @{$dst->registry} = @{$src->registry}; 599 @{$dst->registry} = @{$src->registry};
558 600
… …
560 602
561 %{$dst->{_attachment}} = %{$src->{_attachment}} 603 %{$dst->{_attachment}} = %{$src->{_attachment}}
562 if exists $src->{_attachment}; 604 if exists $src->{_attachment};
563 }, 605 },
564); 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}
565 670
566############################################################################# 671#############################################################################
567# command handling &c 672# command handling &c
568 673
569=item cf::register_command $name => \&callback($ob,$args); 674=item cf::register_command $name => \&callback($ob,$args);
… …
895 1000
896 if (@{ $ns->{query_queue} } == @$queue) { 1001 if (@{ $ns->{query_queue} } == @$queue) {
897 if (@$queue) { 1002 if (@$queue) {
898 $ns->send_packet ($ns->{query_queue}[0][0]); 1003 $ns->send_packet ($ns->{query_queue}[0][0]);
899 } else { 1004 } else {
900 $ns->state (ST_PLAYING); 1005 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
901 } 1006 }
902 } 1007 }
1008 },
1009);
1010
1011=item $client->coro (\&cb)
1012
1013Create a new coroutine, running the specified callback. The coroutine will
1014be automatically cancelled when the client gets destroyed (e.g. on logout,
1015or loss of connection).
1016
1017=cut
1018
1019sub cf::client::coro {
1020 my ($self, $cb) = @_;
1021
1022 my $coro; $coro = async {
1023 eval {
1024 $cb->();
1025 };
1026 warn $@ if $@;
1027 };
1028
1029 $coro->on_destroy (sub {
1030 delete $self->{_coro}{$coro+0};
1031 });
1032
1033 $self->{_coro}{$coro+0} = $coro;
1034
1035 $coro
1036}
1037
1038cf::client->attach (
1039 on_destroy => sub {
1040 my ($ns) = @_;
1041
1042 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
903 }, 1043 },
904); 1044);
905 1045
906=back 1046=back
907 1047
… …
1141} 1281}
1142 1282
1143############################################################################# 1283#############################################################################
1144# initialisation 1284# initialisation
1145 1285
1146sub _perl_reload(&) { 1286sub _perl_reload() {
1147 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 }
1148 1292
1149 $msg->("reloading..."); 1293 warn "reloading...";
1294
1295 local $FREEZE = 1;
1296 cf::emergency_save;
1150 1297
1151 eval { 1298 eval {
1299 # if anything goes wrong in here, we should simply crash as we already saved
1300
1152 # cancel all watchers 1301 # cancel all watchers
1153 for (Event::all_watchers) { 1302 for (Event::all_watchers) {
1154 $_->cancel if $_->data & WF_AUTOCANCEL; 1303 $_->cancel if $_->data & WF_AUTOCANCEL;
1155 } 1304 }
1156 1305
1306 # cancel all extension coros
1307 $_->cancel for values %EXT_CORO;
1308 %EXT_CORO = ();
1309
1157 # unload all extensions 1310 # unload all extensions
1158 for (@exts) { 1311 for (@exts) {
1159 $msg->("unloading <$_>"); 1312 warn "unloading <$_>";
1160 unload_extension $_; 1313 unload_extension $_;
1161 } 1314 }
1162 1315
1163 # unload all modules loaded from $LIBDIR 1316 # unload all modules loaded from $LIBDIR
1164 while (my ($k, $v) = each %INC) { 1317 while (my ($k, $v) = each %INC) {
1165 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 1318 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1166 1319
1167 $msg->("removing <$k>"); 1320 warn "removing <$k>";
1168 delete $INC{$k}; 1321 delete $INC{$k};
1169 1322
1170 $k =~ s/\.pm$//; 1323 $k =~ s/\.pm$//;
1171 $k =~ s/\//::/g; 1324 $k =~ s/\//::/g;
1172 1325
… …
1177 Symbol::delete_package $k; 1330 Symbol::delete_package $k;
1178 } 1331 }
1179 1332
1180 # sync database to disk 1333 # sync database to disk
1181 cf::db_sync; 1334 cf::db_sync;
1335 IO::AIO::flush;
1182 1336
1183 # get rid of safe::, as good as possible 1337 # get rid of safe::, as good as possible
1184 Symbol::delete_package "safe::$_" 1338 Symbol::delete_package "safe::$_"
1185 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);
1186 1340
1187 # remove register_script_function callbacks 1341 # remove register_script_function callbacks
1188 # TODO 1342 # TODO
1189 1343
1190 # unload cf.pm "a bit" 1344 # unload cf.pm "a bit"
… …
1193 # don't, removes xs symbols, too, 1347 # don't, removes xs symbols, too,
1194 # and global variables created in xs 1348 # and global variables created in xs
1195 #Symbol::delete_package __PACKAGE__; 1349 #Symbol::delete_package __PACKAGE__;
1196 1350
1197 # reload cf.pm 1351 # reload cf.pm
1198 $msg->("reloading cf.pm"); 1352 warn "reloading cf.pm";
1199 require cf; 1353 require cf;
1354 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1200 1355
1201 # load config and database again 1356 # load config and database again
1202 cf::cfg_load; 1357 cf::cfg_load;
1203 cf::db_load; 1358 cf::db_load;
1204 1359
1205 # load extensions 1360 # load extensions
1206 $msg->("load extensions"); 1361 warn "load extensions";
1207 cf::load_extensions; 1362 cf::load_extensions;
1208 1363
1209 # reattach attachments to objects 1364 # reattach attachments to objects
1210 $msg->("reattach"); 1365 warn "reattach";
1211 _global_reattach; 1366 _global_reattach;
1212 }; 1367 };
1213 $msg->($@) if $@;
1214 1368
1215 $msg->("reloaded"); 1369 if ($@) {
1370 warn $@;
1371 warn "error while reloading, exiting.";
1372 exit 1;
1373 }
1374
1375 warn "reloaded successfully";
1216}; 1376};
1217 1377
1218sub perl_reload() { 1378sub perl_reload() {
1219 _perl_reload { 1379 _perl_reload;
1220 warn $_[0];
1221 print "$_[0]\n";
1222 };
1223} 1380}
1224 1381
1225register "<global>", __PACKAGE__; 1382register "<global>", __PACKAGE__;
1226 1383
1227register_command "perl-reload" => sub { 1384register_command "perl-reload" => sub {
1228 my ($who, $arg) = @_; 1385 my ($who, $arg) = @_;
1229 1386
1230 if ($who->flag (FLAG_WIZ)) { 1387 if ($who->flag (FLAG_WIZ)) {
1388 $who->message ("reloading...");
1231 _perl_reload { 1389 _perl_reload;
1232 warn $_[0];
1233 $who->message ($_[0]);
1234 };
1235 } 1390 }
1236}; 1391};
1237 1392
1238unshift @INC, $LIBDIR; 1393unshift @INC, $LIBDIR;
1239 1394
1240$TICK_WATCHER = Event->timer ( 1395$TICK_WATCHER = Event->timer (
1396 reentrant => 0,
1241 prio => 0, 1397 prio => 0,
1242 at => $NEXT_TICK || 1, 1398 at => $NEXT_TICK || $TICK,
1243 data => WF_AUTOCANCEL, 1399 data => WF_AUTOCANCEL,
1244 cb => sub { 1400 cb => sub {
1401 unless ($FREEZE) {
1245 cf::server_tick; # one server iteration 1402 cf::server_tick; # one server iteration
1403 $RUNTIME += $TICK;
1404 }
1246 1405
1247 my $NOW = Event::time;
1248 $NEXT_TICK += $TICK; 1406 $NEXT_TICK += $TICK;
1249 1407
1250 # 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
1251 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1409 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
1252 1410
1253 $TICK_WATCHER->at ($NEXT_TICK); 1411 $TICK_WATCHER->at ($NEXT_TICK);
1254 $TICK_WATCHER->start; 1412 $TICK_WATCHER->start;
1255 }, 1413 },
1256); 1414);
… …
1261 poll => 'r', 1419 poll => 'r',
1262 prio => 5, 1420 prio => 5,
1263 data => WF_AUTOCANCEL, 1421 data => WF_AUTOCANCEL,
1264 cb => \&IO::AIO::poll_cb); 1422 cb => \&IO::AIO::poll_cb);
1265 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
12661 14331
1267 1434

Diff Legend

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