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.83 by root, Mon Dec 11 01:30:41 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 = ();
… …
23our $TICK_WATCHER; 28our $TICK_WATCHER;
24our $NEXT_TICK; 29our $NEXT_TICK;
25 30
26our %CFG; 31our %CFG;
27 32
33our $uptime;#d#
34our $UPTIME;
35$UPTIME ||= $uptime;#d#
36$UPTIME ||= time;
37
28############################################################################# 38#############################################################################
29 39
30=head2 GLOBAL VARIABLES 40=head2 GLOBAL VARIABLES
31 41
32=over 4 42=over 4
43
44=item $cf::UPTIME
45
46The timestamp of the server start (so not actually an uptime).
33 47
34=item $cf::LIBDIR 48=item $cf::LIBDIR
35 49
36The perl library directory, where extensions and cf-specific modules can 50The perl library directory, where extensions and cf-specific modules can
37be found. It will be added to C<@INC> automatically. 51be found. It will be added to C<@INC> automatically.
… …
514 unlink $filename; 528 unlink $filename;
515 unlink "$filename.pst"; 529 unlink "$filename.pst";
516 } 530 }
517} 531}
518 532
533sub object_freezer_as_string {
534 my ($rdata, $objs) = @_;
535
536 use Data::Dumper;
537
538 $$rdata . Dumper $objs
539}
540
519sub object_thawer_load { 541sub object_thawer_load {
520 my ($filename) = @_; 542 my ($filename) = @_;
521 543
522 local $/; 544 local $/;
523 545
… …
625 . "#line 1 \"$path\"\n{\n" 647 . "#line 1 \"$path\"\n{\n"
626 . (do { local $/; <$fh> }) 648 . (do { local $/; <$fh> })
627 . "\n};\n1"; 649 . "\n};\n1";
628 650
629 eval $source 651 eval $source
630 or die "$path: $@"; 652 or die $@ ? "$path: $@\n"
653 : "extension disabled.\n";
631 654
632 push @exts, $pkg; 655 push @exts, $pkg;
633 $ext_pkg{$base} = $pkg; 656 $ext_pkg{$base} = $pkg;
634 657
635# no strict 'refs'; 658# no strict 'refs';
… …
766sub cf::player::exists($) { 789sub cf::player::exists($) {
767 cf::player::find $_[0] 790 cf::player::find $_[0]
768 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 791 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
769} 792}
770 793
771=item $player->reply ($npc, $msg[, $flags]) 794=item $player_object->reply ($npc, $msg[, $flags])
772 795
773Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 796Sends 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 797can be C<undef>. Does the right thing when the player is currently in a
775dialogue with the given NPC character. 798dialogue with the given NPC character.
776 799
… …
803 $msg{msgid} = $id; 826 $msg{msgid} = $id;
804 827
805 $self->send ("ext " . to_json \%msg); 828 $self->send ("ext " . to_json \%msg);
806} 829}
807 830
808=back 831=item $player_object->may ("access")
832
833Returns wether the given player is authorized to access resource "access"
834(e.g. "command_wizcast").
835
836=cut
837
838sub cf::object::player::may {
839 my ($self, $access) = @_;
840
841 $self->flag (cf::FLAG_WIZ) ||
842 (ref $cf::CFG{"may_$access"}
843 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
844 : $cf::CFG{"may_$access"})
845}
809 846
810=cut 847=cut
811 848
812############################################################################# 849#############################################################################
813 850
… …
815 852
816Functions that provide a safe environment to compile and execute 853Functions that provide a safe environment to compile and execute
817snippets of perl code without them endangering the safety of the server 854snippets of perl code without them endangering the safety of the server
818itself. Looping constructs, I/O operators and other built-in functionality 855itself. Looping constructs, I/O operators and other built-in functionality
819is not available in the safe scripting environment, and the number of 856is not available in the safe scripting environment, and the number of
820functions and methods that cna be called is greatly reduced. 857functions and methods that can be called is greatly reduced.
821 858
822=cut 859=cut
823 860
824our $safe = new Safe "safe"; 861our $safe = new Safe "safe";
825our $safe_hole = new Safe::Hole; 862our $safe_hole = new Safe::Hole;
… …
961 998
962Immediately write the database to disk I<if it is dirty>. 999Immediately write the database to disk I<if it is dirty>.
963 1000
964=cut 1001=cut
965 1002
1003our $DB;
1004
966{ 1005{
967 my $db;
968 my $path = cf::localdir . "/database.pst"; 1006 my $path = cf::localdir . "/database.pst";
969 1007
970 sub db_load() { 1008 sub db_load() {
971 warn "loading database $path\n";#d# remove later 1009 warn "loading database $path\n";#d# remove later
972 $db = stat $path ? Storable::retrieve $path : { }; 1010 $DB = stat $path ? Storable::retrieve $path : { };
973 } 1011 }
974 1012
975 my $pid; 1013 my $pid;
976 1014
977 sub db_save() { 1015 sub db_save() {
978 warn "saving database $path\n";#d# remove later 1016 warn "saving database $path\n";#d# remove later
979 waitpid $pid, 0 if $pid; 1017 waitpid $pid, 0 if $pid;
980 if (0 == ($pid = fork)) { 1018 if (0 == ($pid = fork)) {
981 $db->{_meta}{version} = 1; 1019 $DB->{_meta}{version} = 1;
982 Storable::nstore $db, "$path~"; 1020 Storable::nstore $DB, "$path~";
983 rename "$path~", $path; 1021 rename "$path~", $path;
984 cf::_exit 0 if defined $pid; 1022 cf::_exit 0 if defined $pid;
985 } 1023 }
986 } 1024 }
987 1025
… …
1001 $idle->start; 1039 $idle->start;
1002 } 1040 }
1003 1041
1004 sub db_get($;$) { 1042 sub db_get($;$) {
1005 @_ >= 2 1043 @_ >= 2
1006 ? $db->{$_[0]}{$_[1]} 1044 ? $DB->{$_[0]}{$_[1]}
1007 : ($db->{$_[0]} ||= { }) 1045 : ($DB->{$_[0]} ||= { })
1008 } 1046 }
1009 1047
1010 sub db_put($$;$) { 1048 sub db_put($$;$) {
1011 if (@_ >= 3) { 1049 if (@_ >= 3) {
1012 $db->{$_[0]}{$_[1]} = $_[2]; 1050 $DB->{$_[0]}{$_[1]} = $_[2];
1013 } else { 1051 } else {
1014 $db->{$_[0]} = $_[1]; 1052 $DB->{$_[0]} = $_[1];
1015 } 1053 }
1016 db_dirty; 1054 db_dirty;
1017 } 1055 }
1018 1056
1019 attach_global 1057 attach_global
… …
1025} 1063}
1026 1064
1027############################################################################# 1065#############################################################################
1028# the server's main() 1066# the server's main()
1029 1067
1068sub cfg_load {
1069 open my $fh, "<:utf8", cf::confdir . "/config"
1070 or return;
1071
1072 local $/;
1073 *CFG = YAML::Syck::Load <$fh>;
1074}
1075
1030sub main { 1076sub main {
1077 cfg_load;
1031 db_load; 1078 db_load;
1032 load_extensions; 1079 load_extensions;
1033 Event::loop; 1080 Event::loop;
1034} 1081}
1035 1082
… …
1087 1134
1088 # reload cf.pm 1135 # reload cf.pm
1089 $msg->("reloading cf.pm"); 1136 $msg->("reloading cf.pm");
1090 require cf; 1137 require cf;
1091 1138
1092 # load database again 1139 # load config and database again
1140 cf::cfg_load;
1093 cf::db_load; 1141 cf::db_load;
1094 1142
1095 # load extensions 1143 # load extensions
1096 $msg->("load extensions"); 1144 $msg->("load extensions");
1097 cf::load_extensions; 1145 cf::load_extensions;
… …
1126register "<global>", __PACKAGE__; 1174register "<global>", __PACKAGE__;
1127 1175
1128unshift @INC, $LIBDIR; 1176unshift @INC, $LIBDIR;
1129 1177
1130$TICK_WATCHER = Event->timer ( 1178$TICK_WATCHER = Event->timer (
1131 prio => 1, 1179 prio => 1,
1180 async => 1,
1132 at => $NEXT_TICK || 1, 1181 at => $NEXT_TICK || 1,
1133 cb => sub { 1182 cb => sub {
1134 cf::server_tick; # one server iteration 1183 cf::server_tick; # one server iteration
1135 1184
1136 my $NOW = Event::time; 1185 my $NOW = Event::time;
1137 $NEXT_TICK += $TICK; 1186 $NEXT_TICK += $TICK;
1138 1187
1139 # if we are delayed by four ticks, skip them all 1188 # if we are delayed by four ticks or more, skip them all
1140 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1189 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1141 1190
1142 $TICK_WATCHER->at ($NEXT_TICK); 1191 $TICK_WATCHER->at ($NEXT_TICK);
1143 $TICK_WATCHER->start; 1192 $TICK_WATCHER->start;
1144 }, 1193 },
1145); 1194);
1146 1195
1196IO::AIO::max_poll_time $TICK * 0.2;
1197
1198Event->io (fd => IO::AIO::poll_fileno,
1199 poll => 'r',
1200 prio => 5,
1201 cb => \&IO::AIO::poll_cb);
1202
11471 12031
1148 1204

Diff Legend

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