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.71 by root, Sun Oct 1 10:59:30 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_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
… …
766sub cf::player::exists($) { 775sub cf::player::exists($) {
767 cf::player::find $_[0] 776 cf::player::find $_[0]
768 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;
769} 778}
770 779
771=item $player->reply ($npc, $msg[, $flags]) 780=item $player_object->reply ($npc, $msg[, $flags])
772 781
773Sends 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>
774can 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
775dialogue with the given NPC character. 784dialogue with the given NPC character.
776 785
… …
803 $msg{msgid} = $id; 812 $msg{msgid} = $id;
804 813
805 $self->send ("ext " . to_json \%msg); 814 $self->send ("ext " . to_json \%msg);
806} 815}
807 816
808=back 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}
809 832
810=cut 833=cut
811 834
812############################################################################# 835#############################################################################
813 836
… …
815 838
816Functions that provide a safe environment to compile and execute 839Functions that provide a safe environment to compile and execute
817snippets of perl code without them endangering the safety of the server 840snippets of perl code without them endangering the safety of the server
818itself. Looping constructs, I/O operators and other built-in functionality 841itself. Looping constructs, I/O operators and other built-in functionality
819is not available in the safe scripting environment, and the number of 842is not available in the safe scripting environment, and the number of
820functions and methods that cna be called is greatly reduced. 843functions and methods that can be called is greatly reduced.
821 844
822=cut 845=cut
823 846
824our $safe = new Safe "safe"; 847our $safe = new Safe "safe";
825our $safe_hole = new Safe::Hole; 848our $safe_hole = new Safe::Hole;
… …
961 984
962Immediately write the database to disk I<if it is dirty>. 985Immediately write the database to disk I<if it is dirty>.
963 986
964=cut 987=cut
965 988
989our $DB;
990
966{ 991{
967 my $db;
968 my $path = cf::localdir . "/database.pst"; 992 my $path = cf::localdir . "/database.pst";
969 993
970 sub db_load() { 994 sub db_load() {
971 warn "loading database $path\n";#d# remove later 995 warn "loading database $path\n";#d# remove later
972 $db = stat $path ? Storable::retrieve $path : { }; 996 $DB = stat $path ? Storable::retrieve $path : { };
973 } 997 }
974 998
975 my $pid; 999 my $pid;
976 1000
977 sub db_save() { 1001 sub db_save() {
978 warn "saving database $path\n";#d# remove later 1002 warn "saving database $path\n";#d# remove later
979 waitpid $pid, 0 if $pid; 1003 waitpid $pid, 0 if $pid;
980 if (0 == ($pid = fork)) { 1004 if (0 == ($pid = fork)) {
981 $db->{_meta}{version} = 1; 1005 $DB->{_meta}{version} = 1;
982 Storable::nstore $db, "$path~"; 1006 Storable::nstore $DB, "$path~";
983 rename "$path~", $path; 1007 rename "$path~", $path;
984 cf::_exit 0 if defined $pid; 1008 cf::_exit 0 if defined $pid;
985 } 1009 }
986 } 1010 }
987 1011
… …
1001 $idle->start; 1025 $idle->start;
1002 } 1026 }
1003 1027
1004 sub db_get($;$) { 1028 sub db_get($;$) {
1005 @_ >= 2 1029 @_ >= 2
1006 ? $db->{$_[0]}{$_[1]} 1030 ? $DB->{$_[0]}{$_[1]}
1007 : ($db->{$_[0]} ||= { }) 1031 : ($DB->{$_[0]} ||= { })
1008 } 1032 }
1009 1033
1010 sub db_put($$;$) { 1034 sub db_put($$;$) {
1011 if (@_ >= 3) { 1035 if (@_ >= 3) {
1012 $db->{$_[0]}{$_[1]} = $_[2]; 1036 $DB->{$_[0]}{$_[1]} = $_[2];
1013 } else { 1037 } else {
1014 $db->{$_[0]} = $_[1]; 1038 $DB->{$_[0]} = $_[1];
1015 } 1039 }
1016 db_dirty; 1040 db_dirty;
1017 } 1041 }
1018 1042
1019 attach_global 1043 attach_global
… …
1025} 1049}
1026 1050
1027############################################################################# 1051#############################################################################
1028# the server's main() 1052# the server's main()
1029 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
1030sub main { 1062sub main {
1063 cfg_load;
1031 db_load; 1064 db_load;
1032 load_extensions; 1065 load_extensions;
1033 Event::loop; 1066 Event::loop;
1034} 1067}
1035 1068
… …
1087 1120
1088 # reload cf.pm 1121 # reload cf.pm
1089 $msg->("reloading cf.pm"); 1122 $msg->("reloading cf.pm");
1090 require cf; 1123 require cf;
1091 1124
1092 # load database again 1125 # load config and database again
1126 cf::cfg_load;
1093 cf::db_load; 1127 cf::db_load;
1094 1128
1095 # load extensions 1129 # load extensions
1096 $msg->("load extensions"); 1130 $msg->("load extensions");
1097 cf::load_extensions; 1131 cf::load_extensions;
… …
1126register "<global>", __PACKAGE__; 1160register "<global>", __PACKAGE__;
1127 1161
1128unshift @INC, $LIBDIR; 1162unshift @INC, $LIBDIR;
1129 1163
1130$TICK_WATCHER = Event->timer ( 1164$TICK_WATCHER = Event->timer (
1131 prio => 1, 1165 prio => 1,
1166 async => 1,
1132 at => $NEXT_TICK || 1, 1167 at => $NEXT_TICK || 1,
1133 cb => sub { 1168 cb => sub {
1134 cf::server_tick; # one server iteration 1169 cf::server_tick; # one server iteration
1135 1170
1136 my $NOW = Event::time; 1171 my $NOW = Event::time;
1137 $NEXT_TICK += $TICK; 1172 $NEXT_TICK += $TICK;
1138 1173
1139 # if we are delayed by four ticks, skip them all 1174 # if we are delayed by four ticks or more, skip them all
1140 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1175 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1141 1176
1142 $TICK_WATCHER->at ($NEXT_TICK); 1177 $TICK_WATCHER->at ($NEXT_TICK);
1143 $TICK_WATCHER->start; 1178 $TICK_WATCHER->start;
1144 }, 1179 },
1145); 1180);
1146 1181
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);
1188
11471 11891
1148 1190

Diff Legend

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