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

Diff Legend

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