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.70 by root, Sun Oct 1 10:55:37 2006 UTC vs.
Revision 1.78 by root, Tue Nov 7 00:15:27 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_init_vars; 21_init_vars;
17 22
18our %COMMAND = (); 23our %COMMAND = ();
… …
22our $TICK = MAX_TIME * 1e-6; 27our $TICK = MAX_TIME * 1e-6;
23our $TICK_WATCHER; 28our $TICK_WATCHER;
24our $NEXT_TICK; 29our $NEXT_TICK;
25 30
26our %CFG; 31our %CFG;
32
33our $uptime;
34
35$uptime ||= time;
27 36
28############################################################################# 37#############################################################################
29 38
30=head2 GLOBAL VARIABLES 39=head2 GLOBAL VARIABLES
31 40
… …
108 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 117 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
109 JSON::Syck::Dump $_[0] 118 JSON::Syck::Dump $_[0]
110} 119}
111 120
112=back 121=back
122
123=cut
113 124
114############################################################################# 125#############################################################################
115 126
116=head2 EVENTS AND OBJECT ATTACHMENTS 127=head2 EVENTS AND OBJECT ATTACHMENTS
117 128
… …
420This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be 431This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
421removed 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
422results (if you must, access C<@cf::invoke_results> directly). 433results (if you must, access C<@cf::invoke_results> directly).
423 434
424=back 435=back
436
437=cut
425 438
426############################################################################# 439#############################################################################
427 440
428=head2 METHODS VALID FOR ALL CORE OBJECTS 441=head2 METHODS VALID FOR ALL CORE OBJECTS
429 442
… …
762sub cf::player::exists($) { 775sub cf::player::exists($) {
763 cf::player::find $_[0] 776 cf::player::find $_[0]
764 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;
765} 778}
766 779
767=item $player->reply ($npc, $msg[, $flags]) 780=item $object->reply ($npc, $msg[, $flags])
768 781
769Sends 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>
770can 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
771dialogue with the given NPC character. 784dialogue with the given NPC character.
772 785
… …
912 *{"safe::$fun"} = $safe_hole->wrap ($cb); 925 *{"safe::$fun"} = $safe_hole->wrap ($cb);
913} 926}
914 927
915=back 928=back
916 929
930=cut
931
917############################################################################# 932#############################################################################
918 933
919=head2 EXTENSION DATABASE SUPPORT 934=head2 EXTENSION DATABASE SUPPORT
920 935
921Crossfire maintains a very simple database for extension use. It can 936Crossfire maintains a very simple database for extension use. It can
… …
955 970
956Immediately write the database to disk I<if it is dirty>. 971Immediately write the database to disk I<if it is dirty>.
957 972
958=cut 973=cut
959 974
975our $DB;
976
960{ 977{
961 my $db;
962 my $path = cf::localdir . "/database.pst"; 978 my $path = cf::localdir . "/database.pst";
963 979
964 sub db_load() { 980 sub db_load() {
965 warn "loading database $path\n";#d# remove later 981 warn "loading database $path\n";#d# remove later
966 $db = stat $path ? Storable::retrieve $path : { }; 982 $DB = stat $path ? Storable::retrieve $path : { };
967 } 983 }
968 984
969 my $pid; 985 my $pid;
970 986
971 sub db_save() { 987 sub db_save() {
972 warn "saving database $path\n";#d# remove later 988 warn "saving database $path\n";#d# remove later
973 waitpid $pid, 0 if $pid; 989 waitpid $pid, 0 if $pid;
974 if (0 == ($pid = fork)) { 990 if (0 == ($pid = fork)) {
975 $db->{_meta}{version} = 1; 991 $DB->{_meta}{version} = 1;
976 Storable::nstore $db, "$path~"; 992 Storable::nstore $DB, "$path~";
977 rename "$path~", $path; 993 rename "$path~", $path;
978 cf::_exit 0 if defined $pid; 994 cf::_exit 0 if defined $pid;
979 } 995 }
980 } 996 }
981 997
… …
995 $idle->start; 1011 $idle->start;
996 } 1012 }
997 1013
998 sub db_get($;$) { 1014 sub db_get($;$) {
999 @_ >= 2 1015 @_ >= 2
1000 ? $db->{$_[0]}{$_[1]} 1016 ? $DB->{$_[0]}{$_[1]}
1001 : ($db->{$_[0]} ||= { }) 1017 : ($DB->{$_[0]} ||= { })
1002 } 1018 }
1003 1019
1004 sub db_put($$;$) { 1020 sub db_put($$;$) {
1005 if (@_ >= 3) { 1021 if (@_ >= 3) {
1006 $db->{$_[0]}{$_[1]} = $_[2]; 1022 $DB->{$_[0]}{$_[1]} = $_[2];
1007 } else { 1023 } else {
1008 $db->{$_[0]} = $_[1]; 1024 $DB->{$_[0]} = $_[1];
1009 } 1025 }
1010 db_dirty; 1026 db_dirty;
1011 } 1027 }
1012 1028
1013 attach_global 1029 attach_global
… …
1019} 1035}
1020 1036
1021############################################################################# 1037#############################################################################
1022# the server's main() 1038# the server's main()
1023 1039
1040sub cfg_load {
1041 open my $fh, "<:utf8", cf::confdir . "/config"
1042 or return;
1043
1044 local $/;
1045 *CFG = YAML::Syck::Load <$fh>;
1046}
1047
1024sub main { 1048sub main {
1049 cfg_load;
1025 db_load; 1050 db_load;
1026 load_extensions; 1051 load_extensions;
1027 Event::loop; 1052 Event::loop;
1028} 1053}
1029 1054
… …
1081 1106
1082 # reload cf.pm 1107 # reload cf.pm
1083 $msg->("reloading cf.pm"); 1108 $msg->("reloading cf.pm");
1084 require cf; 1109 require cf;
1085 1110
1086 # load database again 1111 # load config and database again
1112 cf::cfg_load;
1087 cf::db_load; 1113 cf::db_load;
1088 1114
1089 # load extensions 1115 # load extensions
1090 $msg->("load extensions"); 1116 $msg->("load extensions");
1091 cf::load_extensions; 1117 cf::load_extensions;
… …
1120register "<global>", __PACKAGE__; 1146register "<global>", __PACKAGE__;
1121 1147
1122unshift @INC, $LIBDIR; 1148unshift @INC, $LIBDIR;
1123 1149
1124$TICK_WATCHER = Event->timer ( 1150$TICK_WATCHER = Event->timer (
1125 prio => 1, 1151 prio => 1,
1152 async => 1,
1126 at => $NEXT_TICK || 1, 1153 at => $NEXT_TICK || 1,
1127 cb => sub { 1154 cb => sub {
1128 cf::server_tick; # one server iteration 1155 cf::server_tick; # one server iteration
1129 1156
1130 my $NOW = Event::time; 1157 my $NOW = Event::time;
1131 $NEXT_TICK += $TICK; 1158 $NEXT_TICK += $TICK;
1132 1159
1133 # if we are delayed by four ticks, skip them all 1160 # if we are delayed by four ticks or more, skip them all
1134 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1161 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1135 1162
1136 $TICK_WATCHER->at ($NEXT_TICK); 1163 $TICK_WATCHER->at ($NEXT_TICK);
1137 $TICK_WATCHER->start; 1164 $TICK_WATCHER->start;
1138 }, 1165 },
1139); 1166);
1140 1167
1168eval { IO::AIO::max_poll_time $TICK * 0.2 }; #d# remove eval after restart
1169
1170Event->io (fd => IO::AIO::poll_fileno,
1171 poll => 'r',
1172 prio => 5,
1173 cb => \&IO::AIO::poll_cb);
1174
11411 11751
1142 1176

Diff Legend

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