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.57 by root, Wed Aug 30 11:21:24 2006 UTC vs.
Revision 1.79 by root, Tue Nov 7 14:58:35 2006 UTC

… …
5use Storable; 5use Storable;
6use Opcode; 6use Opcode;
7use Safe; 7use Safe;
8use Safe::Hole; 8use Safe::Hole;
9 9
10use IO::AIO ();
11use YAML::Syck ();
10use Time::HiRes; 12use Time::HiRes;
11use Event; 13use Event;
12$Event::Eval = 1; # no idea why this is required, but it is 14$Event::Eval = 1; # no idea why this is required, but it is
13 15
16# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
17$YAML::Syck::ImplicitUnicode = 1;
18
14use strict; 19use strict;
15 20
16_reload_1; 21_init_vars;
17 22
18our %COMMAND = (); 23our %COMMAND = ();
19our @EVENT; 24our @EVENT;
20our %PROP_TYPE;
21our %PROP_IDX;
22our $LIBDIR = maps_directory "perl"; 25our $LIBDIR = maps_directory "perl";
23 26
24our $TICK = MAX_TIME * 1e-6; 27our $TICK = MAX_TIME * 1e-6;
25our $TICK_WATCHER; 28our $TICK_WATCHER;
26our $NEXT_TICK; 29our $NEXT_TICK;
30
31our %CFG;
32
33our $uptime;
34
35$uptime ||= time;
36
37#############################################################################
38
39=head2 GLOBAL VARIABLES
40
41=over 4
42
43=item $cf::LIBDIR
44
45The perl library directory, where extensions and cf-specific modules can
46be found. It will be added to C<@INC> automatically.
47
48=item $cf::TICK
49
50The interval between server ticks, in seconds.
51
52=item %cf::CFG
53
54Configuration for the server, loaded from C</etc/crossfire/config>, or
55from wherever your confdir points to.
56
57=back
58
59=cut
27 60
28BEGIN { 61BEGIN {
29 *CORE::GLOBAL::warn = sub { 62 *CORE::GLOBAL::warn = sub {
30 my $msg = join "", @_; 63 my $msg = join "", @_;
31 $msg .= "\n" 64 $msg .= "\n"
… …
34 print STDERR "cfperl: $msg"; 67 print STDERR "cfperl: $msg";
35 LOG llevError, "cfperl: $msg"; 68 LOG llevError, "cfperl: $msg";
36 }; 69 };
37} 70}
38 71
39my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply!
40
41# generate property mutators
42sub prop_gen {
43 my ($prefix, $class) = @_;
44
45 no strict 'refs';
46
47 for my $prop (keys %PROP_TYPE) {
48 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
49 my $sub = lc $1;
50
51 my $type = $PROP_TYPE{$prop};
52 my $idx = $PROP_IDX {$prop};
53
54 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
55 $_[0]->get_property ($type, $idx)
56 };
57
58 *{"$class\::set_$sub"} = sub {
59 $_[0]->set_property ($type, $idx, $_[1]);
60 } unless $ignore_set{$prop};
61 }
62}
63
64# auto-generate most of the API
65
66prop_gen OBJECT_PROP => "cf::object";
67# CFAPI_OBJECT_ANIMATION?
68prop_gen PLAYER_PROP => "cf::object::player";
69
70prop_gen MAP_PROP => "cf::map";
71prop_gen ARCH_PROP => "cf::arch";
72
73@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 72@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
74 73
75# we bless all objects into (empty) derived classes to force a method lookup 74# we bless all objects into (empty) derived classes to force a method lookup
76# within the Safe compartment. 75# within the Safe compartment.
77for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) { 76for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) {
… …
87my @exts; 86my @exts;
88my @hook; 87my @hook;
89my %command; 88my %command;
90my %extcmd; 89my %extcmd;
91 90
92############################################################################# 91=head2 UTILITY FUNCTIONS
93# utility functions 92
93=over 4
94
95=cut
94 96
95use JSON::Syck (); # TODO# replace by JSON::PC once working 97use JSON::Syck (); # TODO# replace by JSON::PC once working
98
99=item $ref = cf::from_json $json
100
101Converts a JSON string into the corresponding perl data structure.
102
103=cut
96 104
97sub from_json($) { 105sub from_json($) {
98 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs 106 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
99 JSON::Syck::Load $_[0] 107 JSON::Syck::Load $_[0]
100} 108}
101 109
110=item $json = cf::to_json $ref
111
112Converts a perl data structure into its JSON representation.
113
114=cut
115
102sub to_json($) { 116sub to_json($) {
103 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 117 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
104 JSON::Syck::Dump $_[0] 118 JSON::Syck::Dump $_[0]
105} 119}
106 120
107############################################################################# 121=back
108# "new" plug-in system
109 122
123=cut
124
125#############################################################################
126
110=head3 EVENTS AND OBJECT ATTACHMENTS 127=head2 EVENTS AND OBJECT ATTACHMENTS
111 128
112=over 4 129=over 4
113 130
114=item $object->attach ($attachment, key => $value...) 131=item $object->attach ($attachment, key => $value...)
115 132
… …
389 for (@$callbacks) { 406 for (@$callbacks) {
390 eval { &{$_->[1]} }; 407 eval { &{$_->[1]} };
391 408
392 if ($@) { 409 if ($@) {
393 warn "$@"; 410 warn "$@";
394 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n"; 411 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
395 override; 412 override;
396 } 413 }
397 414
398 return 1 if $override; 415 return 1 if $override;
399 } 416 }
… …
415removed in future versions), and there is no public API to access override 432removed in future versions), and there is no public API to access override
416results (if you must, access C<@cf::invoke_results> directly). 433results (if you must, access C<@cf::invoke_results> directly).
417 434
418=back 435=back
419 436
420=head2 methods valid for all pointers 437=cut
438
439#############################################################################
440
441=head2 METHODS VALID FOR ALL CORE OBJECTS
421 442
422=over 4 443=over 4
423 444
424=item $object->valid 445=item $object->valid, $player->valid, $map->valid
425
426=item $player->valid
427
428=item $map->valid
429 446
430Just because you have a perl object does not mean that the corresponding 447Just because you have a perl object does not mean that the corresponding
431C-level object still exists. If you try to access an object that has no 448C-level object still exists. If you try to access an object that has no
432valid C counterpart anymore you get an exception at runtime. This method 449valid C counterpart anymore you get an exception at runtime. This method
433can be used to test for existence of the C object part without causing an 450can be used to test for existence of the C object part without causing an
… …
476 } 493 }
477 } 494 }
478} 495}
479 496
480sub object_freezer_save { 497sub object_freezer_save {
481 my ($filename, $objs) = @_; 498 my ($filename, $rdata, $objs) = @_;
482 499
483 if (@$objs) { 500 if (length $$rdata) {
501 warn sprintf "saving %s (%d,%d)\n",
502 $filename, length $$rdata, scalar @$objs;
503
484 open my $fh, ">:raw", "$filename.pst~"; 504 if (open my $fh, ">:raw", "$filename~") {
505 chmod SAVE_MODE, $fh;
506 syswrite $fh, $$rdata;
507 close $fh;
508
509 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
510 chmod SAVE_MODE, $fh;
485 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 511 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
486 close $fh; 512 close $fh;
487 unlink "$filename.cfperl";
488 chmod SAVE_MODE, "$filename.pst~";
489 rename "$filename.pst~", "$filename.pst"; 513 rename "$filename.pst~", "$filename.pst";
514 } else {
515 unlink "$filename.pst";
516 }
517
518 rename "$filename~", $filename;
519 } else {
520 warn "FATAL: $filename~: $!\n";
521 }
490 } else { 522 } else {
523 unlink $filename;
491 unlink "$filename.pst"; 524 unlink "$filename.pst";
492 } 525 }
493
494 chmod SAVE_MODE, "$filename~";
495 rename "$filename~", $filename;
496} 526}
497 527
498sub object_thawer_load { 528sub object_thawer_load {
499 my ($filename) = @_; 529 my ($filename) = @_;
500 530
531 local $/;
532
533 my $av;
534
535 #TODO: use sysread etc.
536 if (open my $data, "<:raw:perlio", $filename) {
537 $data = <$data>;
501 open my $fh, "<:raw:perlio", "$filename.pst" 538 if (open my $pst, "<:raw:perlio", "$filename.pst") {
502 or return; 539 $av = eval { (Storable::thaw <$pst>)->{objs} };
540 }
541 return ($data, $av);
542 }
503 543
504 eval { local $/; (Storable::thaw <$fh>)->{objs} } 544 ()
505} 545}
506 546
507attach_to_objects 547attach_to_objects
508 prio => -1000000, 548 prio => -1000000,
509 on_clone => sub { 549 on_clone => sub {
… …
655 load_extension $ext; 695 load_extension $ext;
656 1 696 1
657 } or warn "$ext not loaded: $@"; 697 } or warn "$ext not loaded: $@";
658 } 698 }
659} 699}
660
661sub _perl_reload(&) {
662 my ($msg) = @_;
663
664 $msg->("reloading...");
665
666 eval {
667 # 1. cancel all watchers
668 $_->cancel for Event::all_watchers;
669
670 # 2. unload all extensions
671 for (@exts) {
672 $msg->("unloading <$_>");
673 unload_extension $_;
674 }
675
676 # 3. unload all modules loaded from $LIBDIR
677 while (my ($k, $v) = each %INC) {
678 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
679
680 $msg->("removing <$k>");
681 delete $INC{$k};
682
683 $k =~ s/\.pm$//;
684 $k =~ s/\//::/g;
685
686 if (my $cb = $k->can ("unload_module")) {
687 $cb->();
688 }
689
690 Symbol::delete_package $k;
691 }
692
693 # 4. get rid of safe::, as good as possible
694 Symbol::delete_package "safe::$_"
695 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
696
697 # 5. remove register_script_function callbacks
698 # TODO
699
700 # 6. unload cf.pm "a bit"
701 delete $INC{"cf.pm"};
702
703 # don't, removes xs symbols, too,
704 # and global variables created in xs
705 #Symbol::delete_package __PACKAGE__;
706
707 # 7. reload cf.pm
708 $msg->("reloading cf.pm");
709 require cf;
710 };
711 $msg->($@) if $@;
712
713 $msg->("reloaded");
714};
715
716sub perl_reload() {
717 _perl_reload {
718 warn $_[0];
719 print "$_[0]\n";
720 };
721}
722
723register_command "perl-reload", 0, sub {
724 my ($who, $arg) = @_;
725
726 if ($who->flag (FLAG_WIZ)) {
727 _perl_reload {
728 warn $_[0];
729 $who->message ($_[0]);
730 };
731 }
732};
733 700
734############################################################################# 701#############################################################################
735# extcmd framework, basically convert ext <msg> 702# extcmd framework, basically convert ext <msg>
736# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 703# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
737 704
… …
765 defined $path or return; 732 defined $path or return;
766 733
767 unlink "$path.pst"; 734 unlink "$path.pst";
768}; 735};
769 736
770# old style persistent data, TODO: remove #d#
771*cf::mapsupport::on_swapin = sub {
772 my ($map) = @_;
773
774 my $path = $map->tmpname;
775 $path = $map->path unless defined $path;
776
777 open my $fh, "<:raw", "$path.cfperl"
778 or return; # no perl data
779
780 my $data = Storable::thaw do { local $/; <$fh> };
781
782 $data->{version} <= 1
783 or return; # too new
784
785 $map->_set_obs ($data->{obs});
786 $map->invoke (EVENT_MAP_UPGRADE);
787};
788
789attach_to_maps prio => -10000, package => cf::mapsupport::; 737attach_to_maps prio => -10000, package => cf::mapsupport::;
790 738
791############################################################################# 739#############################################################################
792# load/save perl data associated with player->ob objects 740# load/save perl data associated with player->ob objects
793 741
794sub all_objects(@) { 742sub all_objects(@) {
795 @_, map all_objects ($_->inv), @_ 743 @_, map all_objects ($_->inv), @_
796} 744}
797 745
746# TODO: compatibility cruft, remove when no longer needed
798attach_to_players 747attach_to_players
799 on_load => sub { 748 on_load => sub {
800 my ($pl, $path) = @_; 749 my ($pl, $path) = @_;
801 750
802 for my $o (all_objects $pl->ob) { 751 for my $o (all_objects $pl->ob) {
… …
808 } 757 }
809 }, 758 },
810; 759;
811 760
812############################################################################# 761#############################################################################
813# core extensions - in perl 762
763=head2 CORE EXTENSIONS
764
765Functions and methods that extend core crossfire objects.
766
767=over 4
814 768
815=item cf::player::exists $login 769=item cf::player::exists $login
816 770
817Returns true when the given account exists. 771Returns true when the given account exists.
818 772
… …
821sub cf::player::exists($) { 775sub cf::player::exists($) {
822 cf::player::find $_[0] 776 cf::player::find $_[0]
823 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 777 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
824} 778}
825 779
826=item $player->reply ($npc, $msg[, $flags]) 780=item $player_object->reply ($npc, $msg[, $flags])
827 781
828Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 782Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
829can be C<undef>. Does the right thing when the player is currently in a 783can be C<undef>. Does the right thing when the player is currently in a
830dialogue with the given NPC character. 784dialogue with the given NPC character.
831 785
… …
858 $msg{msgid} = $id; 812 $msg{msgid} = $id;
859 813
860 $self->send ("ext " . to_json \%msg); 814 $self->send ("ext " . to_json \%msg);
861} 815}
862 816
817=item $player_object->may ("access")
818
819Returns wether the given player is authorized to access resource "access"
820(e.g. "command_wizcast").
821
822=cut
823
824sub cf::object::player::may {
825 my ($self, $access) = @_;
826
827 $self->flag (cf::FLAG_WIZ) ||
828 (ref $cf::CFG{"may_$access"}
829 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
830 : $cf::CFG{"may_$access"})
831}
832
833=cut
834
863############################################################################# 835#############################################################################
864# map scripting support 836
837=head2 SAFE SCRIPTING
838
839Functions that provide a safe environment to compile and execute
840snippets of perl code without them endangering the safety of the server
841itself. Looping constructs, I/O operators and other built-in functionality
842is not available in the safe scripting environment, and the number of
843functions and methods that can be called is greatly reduced.
844
845=cut
865 846
866our $safe = new Safe "safe"; 847our $safe = new Safe "safe";
867our $safe_hole = new Safe::Hole; 848our $safe_hole = new Safe::Hole;
868 849
869$SIG{FPE} = 'IGNORE'; 850$SIG{FPE} = 'IGNORE';
870 851
871$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 852$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
872 853
873# here we export the classes and methods available to script code 854# here we export the classes and methods available to script code
855
856=pod
857
858The following fucntions and emthods are available within a safe environment:
859
860 cf::object contr pay_amount pay_player
861 cf::object::player player
862 cf::player peaceful
863
864=cut
874 865
875for ( 866for (
876 ["cf::object" => qw(contr pay_amount pay_player)], 867 ["cf::object" => qw(contr pay_amount pay_player)],
877 ["cf::object::player" => qw(player)], 868 ["cf::object::player" => qw(player)],
878 ["cf::player" => qw(peaceful)], 869 ["cf::player" => qw(peaceful)],
… …
881 my ($pkg, @funs) = @$_; 872 my ($pkg, @funs) = @$_;
882 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 873 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
883 for @funs; 874 for @funs;
884} 875}
885 876
877=over 4
878
879=item @retval = safe_eval $code, [var => value, ...]
880
881Compiled and executes the given perl code snippet. additional var/value
882pairs result in temporary local (my) scalar variables of the given name
883that are available in the code snippet. Example:
884
885 my $five = safe_eval '$first + $second', first => 1, second => 4;
886
887=cut
888
886sub safe_eval($;@) { 889sub safe_eval($;@) {
887 my ($code, %vars) = @_; 890 my ($code, %vars) = @_;
888 891
889 my $qcode = $code; 892 my $qcode = $code;
890 $qcode =~ s/"/‟/g; # not allowed in #line filenames 893 $qcode =~ s/"/‟/g; # not allowed in #line filenames
… …
912 } 915 }
913 916
914 wantarray ? @res : $res[0] 917 wantarray ? @res : $res[0]
915} 918}
916 919
920=item cf::register_script_function $function => $cb
921
922Register a function that can be called from within map/npc scripts. The
923function should be reasonably secure and should be put into a package name
924like the extension.
925
926Example: register a function that gets called whenever a map script calls
927C<rent::overview>, as used by the C<rent> extension.
928
929 cf::register_script_function "rent::overview" => sub {
930 ...
931 };
932
933=cut
934
917sub register_script_function { 935sub register_script_function {
918 my ($fun, $cb) = @_; 936 my ($fun, $cb) = @_;
919 937
920 no strict 'refs'; 938 no strict 'refs';
921 *{"safe::$fun"} = $safe_hole->wrap ($cb); 939 *{"safe::$fun"} = $safe_hole->wrap ($cb);
922} 940}
923 941
942=back
943
944=cut
945
946#############################################################################
947
948=head2 EXTENSION DATABASE SUPPORT
949
950Crossfire maintains a very simple database for extension use. It can
951currently store anything that can be serialised using Storable, which
952excludes objects.
953
954The parameter C<$family> should best start with the name of the extension
955using it, it should be unique.
956
957=over 4
958
959=item $hashref = cf::db_get $family
960
961Return a hashref for use by the extension C<$family>, which can be
962modified. After modifications, you have to call C<cf::db_dirty> or
963C<cf::db_sync>.
964
965=item $value = cf::db_get $family => $key
966
967Returns a single value from the database
968
969=item cf::db_put $family => $hashref
970
971Stores the given family hashref into the database. Updates are delayed, if
972you want the data to be synced to disk immediately, use C<cf::db_sync>.
973
974=item cf::db_put $family => $key => $value
975
976Stores the given C<$value> in the family hash. Updates are delayed, if you
977want the data to be synced to disk immediately, use C<cf::db_sync>.
978
979=item cf::db_dirty
980
981Marks the database as dirty, to be updated at a later time.
982
983=item cf::db_sync
984
985Immediately write the database to disk I<if it is dirty>.
986
987=cut
988
989our $DB;
990
991{
992 my $path = cf::localdir . "/database.pst";
993
994 sub db_load() {
995 warn "loading database $path\n";#d# remove later
996 $DB = stat $path ? Storable::retrieve $path : { };
997 }
998
999 my $pid;
1000
1001 sub db_save() {
1002 warn "saving database $path\n";#d# remove later
1003 waitpid $pid, 0 if $pid;
1004 if (0 == ($pid = fork)) {
1005 $DB->{_meta}{version} = 1;
1006 Storable::nstore $DB, "$path~";
1007 rename "$path~", $path;
1008 cf::_exit 0 if defined $pid;
1009 }
1010 }
1011
1012 my $dirty;
1013
1014 sub db_sync() {
1015 db_save if $dirty;
1016 undef $dirty;
1017 }
1018
1019 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub {
1020 db_sync;
1021 });
1022
1023 sub db_dirty() {
1024 $dirty = 1;
1025 $idle->start;
1026 }
1027
1028 sub db_get($;$) {
1029 @_ >= 2
1030 ? $DB->{$_[0]}{$_[1]}
1031 : ($DB->{$_[0]} ||= { })
1032 }
1033
1034 sub db_put($$;$) {
1035 if (@_ >= 3) {
1036 $DB->{$_[0]}{$_[1]} = $_[2];
1037 } else {
1038 $DB->{$_[0]} = $_[1];
1039 }
1040 db_dirty;
1041 }
1042
1043 attach_global
1044 prio => 10000,
1045 on_cleanup => sub {
1046 db_sync;
1047 },
1048 ;
1049}
1050
924############################################################################# 1051#############################################################################
925# the server's main() 1052# the server's main()
926 1053
1054sub cfg_load {
1055 open my $fh, "<:utf8", cf::confdir . "/config"
1056 or return;
1057
1058 local $/;
1059 *CFG = YAML::Syck::Load <$fh>;
1060}
1061
927sub main { 1062sub main {
1063 cfg_load;
1064 db_load;
1065 load_extensions;
928 Event::loop; 1066 Event::loop;
929} 1067}
930 1068
931############################################################################# 1069#############################################################################
932# initialisation 1070# initialisation
933 1071
1072sub _perl_reload(&) {
1073 my ($msg) = @_;
1074
1075 $msg->("reloading...");
1076
1077 eval {
1078 # cancel all watchers
1079 $_->cancel for Event::all_watchers;
1080
1081 # unload all extensions
1082 for (@exts) {
1083 $msg->("unloading <$_>");
1084 unload_extension $_;
1085 }
1086
1087 # unload all modules loaded from $LIBDIR
1088 while (my ($k, $v) = each %INC) {
1089 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1090
1091 $msg->("removing <$k>");
1092 delete $INC{$k};
1093
1094 $k =~ s/\.pm$//;
1095 $k =~ s/\//::/g;
1096
1097 if (my $cb = $k->can ("unload_module")) {
1098 $cb->();
1099 }
1100
1101 Symbol::delete_package $k;
1102 }
1103
1104 # sync database to disk
1105 cf::db_sync;
1106
1107 # get rid of safe::, as good as possible
1108 Symbol::delete_package "safe::$_"
1109 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
1110
1111 # remove register_script_function callbacks
1112 # TODO
1113
1114 # unload cf.pm "a bit"
1115 delete $INC{"cf.pm"};
1116
1117 # don't, removes xs symbols, too,
1118 # and global variables created in xs
1119 #Symbol::delete_package __PACKAGE__;
1120
1121 # reload cf.pm
1122 $msg->("reloading cf.pm");
1123 require cf;
1124
1125 # load config and database again
1126 cf::cfg_load;
1127 cf::db_load;
1128
1129 # load extensions
1130 $msg->("load extensions");
1131 cf::load_extensions;
1132
1133 # reattach attachments to objects
1134 $msg->("reattach");
1135 _global_reattach;
1136 };
1137 $msg->($@) if $@;
1138
1139 $msg->("reloaded");
1140};
1141
1142sub perl_reload() {
1143 _perl_reload {
1144 warn $_[0];
1145 print "$_[0]\n";
1146 };
1147}
1148
1149register_command "perl-reload", 0, sub {
1150 my ($who, $arg) = @_;
1151
1152 if ($who->flag (FLAG_WIZ)) {
1153 _perl_reload {
1154 warn $_[0];
1155 $who->message ($_[0]);
1156 };
1157 }
1158};
1159
934register "<global>", __PACKAGE__; 1160register "<global>", __PACKAGE__;
935 1161
936unshift @INC, $LIBDIR; 1162unshift @INC, $LIBDIR;
937 1163
938load_extensions;
939
940$TICK_WATCHER = Event->timer ( 1164$TICK_WATCHER = Event->timer (
941 prio => 1, 1165 prio => 1,
1166 async => 1,
942 at => $NEXT_TICK || 1, 1167 at => $NEXT_TICK || 1,
943 cb => sub { 1168 cb => sub {
944 cf::server_tick; # one server iteration 1169 cf::server_tick; # one server iteration
945 1170
946 my $NOW = Event::time; 1171 my $NOW = Event::time;
947 $NEXT_TICK += $TICK; 1172 $NEXT_TICK += $TICK;
948 1173
949 # if we are delayed by four ticks, skip them all 1174 # if we are delayed by four ticks or more, skip them all
950 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1175 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
951 1176
952 $TICK_WATCHER->at ($NEXT_TICK); 1177 $TICK_WATCHER->at ($NEXT_TICK);
953 $TICK_WATCHER->start; 1178 $TICK_WATCHER->start;
954 }, 1179 },
955); 1180);
956 1181
957_reload_2; 1182eval { IO::AIO::max_poll_time $TICK * 0.2 }; #d# remove eval after restart
1183
1184Event->io (fd => IO::AIO::poll_fileno,
1185 poll => 'r',
1186 prio => 5,
1187 cb => \&IO::AIO::poll_cb);
958 1188
9591 11891
960 1190

Diff Legend

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