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.80 by root, Tue Nov 7 16:30:55 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
… …
514 unlink $filename; 523 unlink $filename;
515 unlink "$filename.pst"; 524 unlink "$filename.pst";
516 } 525 }
517} 526}
518 527
528sub object_freezer_as_string {
529 my ($rdata, $objs) = @_;
530
531 use Data::Dumper;
532
533 "$$rdata\n" . Dumper $objs
534}
535
519sub object_thawer_load { 536sub object_thawer_load {
520 my ($filename) = @_; 537 my ($filename) = @_;
521 538
522 local $/; 539 local $/;
523 540
… …
766sub cf::player::exists($) { 783sub cf::player::exists($) {
767 cf::player::find $_[0] 784 cf::player::find $_[0]
768 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 785 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
769} 786}
770 787
771=item $player->reply ($npc, $msg[, $flags]) 788=item $player_object->reply ($npc, $msg[, $flags])
772 789
773Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 790Sends 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 791can be C<undef>. Does the right thing when the player is currently in a
775dialogue with the given NPC character. 792dialogue with the given NPC character.
776 793
… …
803 $msg{msgid} = $id; 820 $msg{msgid} = $id;
804 821
805 $self->send ("ext " . to_json \%msg); 822 $self->send ("ext " . to_json \%msg);
806} 823}
807 824
808=back 825=item $player_object->may ("access")
826
827Returns wether the given player is authorized to access resource "access"
828(e.g. "command_wizcast").
829
830=cut
831
832sub cf::object::player::may {
833 my ($self, $access) = @_;
834
835 $self->flag (cf::FLAG_WIZ) ||
836 (ref $cf::CFG{"may_$access"}
837 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
838 : $cf::CFG{"may_$access"})
839}
809 840
810=cut 841=cut
811 842
812############################################################################# 843#############################################################################
813 844
… …
815 846
816Functions that provide a safe environment to compile and execute 847Functions that provide a safe environment to compile and execute
817snippets of perl code without them endangering the safety of the server 848snippets of perl code without them endangering the safety of the server
818itself. Looping constructs, I/O operators and other built-in functionality 849itself. Looping constructs, I/O operators and other built-in functionality
819is not available in the safe scripting environment, and the number of 850is not available in the safe scripting environment, and the number of
820functions and methods that cna be called is greatly reduced. 851functions and methods that can be called is greatly reduced.
821 852
822=cut 853=cut
823 854
824our $safe = new Safe "safe"; 855our $safe = new Safe "safe";
825our $safe_hole = new Safe::Hole; 856our $safe_hole = new Safe::Hole;
… …
961 992
962Immediately write the database to disk I<if it is dirty>. 993Immediately write the database to disk I<if it is dirty>.
963 994
964=cut 995=cut
965 996
997our $DB;
998
966{ 999{
967 my $db;
968 my $path = cf::localdir . "/database.pst"; 1000 my $path = cf::localdir . "/database.pst";
969 1001
970 sub db_load() { 1002 sub db_load() {
971 warn "loading database $path\n";#d# remove later 1003 warn "loading database $path\n";#d# remove later
972 $db = stat $path ? Storable::retrieve $path : { }; 1004 $DB = stat $path ? Storable::retrieve $path : { };
973 } 1005 }
974 1006
975 my $pid; 1007 my $pid;
976 1008
977 sub db_save() { 1009 sub db_save() {
978 warn "saving database $path\n";#d# remove later 1010 warn "saving database $path\n";#d# remove later
979 waitpid $pid, 0 if $pid; 1011 waitpid $pid, 0 if $pid;
980 if (0 == ($pid = fork)) { 1012 if (0 == ($pid = fork)) {
981 $db->{_meta}{version} = 1; 1013 $DB->{_meta}{version} = 1;
982 Storable::nstore $db, "$path~"; 1014 Storable::nstore $DB, "$path~";
983 rename "$path~", $path; 1015 rename "$path~", $path;
984 cf::_exit 0 if defined $pid; 1016 cf::_exit 0 if defined $pid;
985 } 1017 }
986 } 1018 }
987 1019
… …
1001 $idle->start; 1033 $idle->start;
1002 } 1034 }
1003 1035
1004 sub db_get($;$) { 1036 sub db_get($;$) {
1005 @_ >= 2 1037 @_ >= 2
1006 ? $db->{$_[0]}{$_[1]} 1038 ? $DB->{$_[0]}{$_[1]}
1007 : ($db->{$_[0]} ||= { }) 1039 : ($DB->{$_[0]} ||= { })
1008 } 1040 }
1009 1041
1010 sub db_put($$;$) { 1042 sub db_put($$;$) {
1011 if (@_ >= 3) { 1043 if (@_ >= 3) {
1012 $db->{$_[0]}{$_[1]} = $_[2]; 1044 $DB->{$_[0]}{$_[1]} = $_[2];
1013 } else { 1045 } else {
1014 $db->{$_[0]} = $_[1]; 1046 $DB->{$_[0]} = $_[1];
1015 } 1047 }
1016 db_dirty; 1048 db_dirty;
1017 } 1049 }
1018 1050
1019 attach_global 1051 attach_global
… …
1025} 1057}
1026 1058
1027############################################################################# 1059#############################################################################
1028# the server's main() 1060# the server's main()
1029 1061
1062sub cfg_load {
1063 open my $fh, "<:utf8", cf::confdir . "/config"
1064 or return;
1065
1066 local $/;
1067 *CFG = YAML::Syck::Load <$fh>;
1068}
1069
1030sub main { 1070sub main {
1071 cfg_load;
1031 db_load; 1072 db_load;
1032 load_extensions; 1073 load_extensions;
1033 Event::loop; 1074 Event::loop;
1034} 1075}
1035 1076
… …
1087 1128
1088 # reload cf.pm 1129 # reload cf.pm
1089 $msg->("reloading cf.pm"); 1130 $msg->("reloading cf.pm");
1090 require cf; 1131 require cf;
1091 1132
1092 # load database again 1133 # load config and database again
1134 cf::cfg_load;
1093 cf::db_load; 1135 cf::db_load;
1094 1136
1095 # load extensions 1137 # load extensions
1096 $msg->("load extensions"); 1138 $msg->("load extensions");
1097 cf::load_extensions; 1139 cf::load_extensions;
… …
1126register "<global>", __PACKAGE__; 1168register "<global>", __PACKAGE__;
1127 1169
1128unshift @INC, $LIBDIR; 1170unshift @INC, $LIBDIR;
1129 1171
1130$TICK_WATCHER = Event->timer ( 1172$TICK_WATCHER = Event->timer (
1131 prio => 1, 1173 prio => 1,
1174 async => 1,
1132 at => $NEXT_TICK || 1, 1175 at => $NEXT_TICK || 1,
1133 cb => sub { 1176 cb => sub {
1134 cf::server_tick; # one server iteration 1177 cf::server_tick; # one server iteration
1135 1178
1136 my $NOW = Event::time; 1179 my $NOW = Event::time;
1137 $NEXT_TICK += $TICK; 1180 $NEXT_TICK += $TICK;
1138 1181
1139 # if we are delayed by four ticks, skip them all 1182 # if we are delayed by four ticks or more, skip them all
1140 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1183 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1141 1184
1142 $TICK_WATCHER->at ($NEXT_TICK); 1185 $TICK_WATCHER->at ($NEXT_TICK);
1143 $TICK_WATCHER->start; 1186 $TICK_WATCHER->start;
1144 }, 1187 },
1145); 1188);
1146 1189
1190IO::AIO::max_poll_time $TICK * 0.2;
1191
1192Event->io (fd => IO::AIO::poll_fileno,
1193 poll => 'r',
1194 prio => 5,
1195 cb => \&IO::AIO::poll_cb);
1196
11471 11971
1148 1198

Diff Legend

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