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.73 by root, Sun Oct 1 11:46:51 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 ();
10use YAML::Syck (); 11use YAML::Syck ();
11use Time::HiRes; 12use Time::HiRes;
12use Event; 13use Event;
13$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
14 15
… …
27our $TICK_WATCHER; 28our $TICK_WATCHER;
28our $NEXT_TICK; 29our $NEXT_TICK;
29 30
30our %CFG; 31our %CFG;
31 32
33our $UPTIME; $UPTIME ||= time;
34
32############################################################################# 35#############################################################################
33 36
34=head2 GLOBAL VARIABLES 37=head2 GLOBAL VARIABLES
35 38
36=over 4 39=over 4
40
41=item $cf::UPTIME
42
43The timestamp of the server start (so not actually an uptime).
37 44
38=item $cf::LIBDIR 45=item $cf::LIBDIR
39 46
40The perl library directory, where extensions and cf-specific modules can 47The perl library directory, where extensions and cf-specific modules can
41be found. It will be added to C<@INC> automatically. 48be found. It will be added to C<@INC> automatically.
… …
518 unlink $filename; 525 unlink $filename;
519 unlink "$filename.pst"; 526 unlink "$filename.pst";
520 } 527 }
521} 528}
522 529
530sub object_freezer_as_string {
531 my ($rdata, $objs) = @_;
532
533 use Data::Dumper;
534
535 $$rdata . Dumper $objs
536}
537
523sub object_thawer_load { 538sub object_thawer_load {
524 my ($filename) = @_; 539 my ($filename) = @_;
525 540
526 local $/; 541 local $/;
527 542
… …
629 . "#line 1 \"$path\"\n{\n" 644 . "#line 1 \"$path\"\n{\n"
630 . (do { local $/; <$fh> }) 645 . (do { local $/; <$fh> })
631 . "\n};\n1"; 646 . "\n};\n1";
632 647
633 eval $source 648 eval $source
634 or die "$path: $@"; 649 or die $@ ? "$path: $@\n"
650 : "extension disabled.\n";
635 651
636 push @exts, $pkg; 652 push @exts, $pkg;
637 $ext_pkg{$base} = $pkg; 653 $ext_pkg{$base} = $pkg;
638 654
639# no strict 'refs'; 655# no strict 'refs';
… …
770sub cf::player::exists($) { 786sub cf::player::exists($) {
771 cf::player::find $_[0] 787 cf::player::find $_[0]
772 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;
773} 789}
774 790
775=item $player->reply ($npc, $msg[, $flags]) 791=item $player_object->reply ($npc, $msg[, $flags])
776 792
777Sends 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>
778can 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
779dialogue with the given NPC character. 795dialogue with the given NPC character.
780 796
… …
807 $msg{msgid} = $id; 823 $msg{msgid} = $id;
808 824
809 $self->send ("ext " . to_json \%msg); 825 $self->send ("ext " . to_json \%msg);
810} 826}
811 827
812=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}
813 843
814=cut 844=cut
815 845
816############################################################################# 846#############################################################################
817 847
… …
819 849
820Functions that provide a safe environment to compile and execute 850Functions that provide a safe environment to compile and execute
821snippets of perl code without them endangering the safety of the server 851snippets of perl code without them endangering the safety of the server
822itself. Looping constructs, I/O operators and other built-in functionality 852itself. Looping constructs, I/O operators and other built-in functionality
823is not available in the safe scripting environment, and the number of 853is not available in the safe scripting environment, and the number of
824functions and methods that cna be called is greatly reduced. 854functions and methods that can be called is greatly reduced.
825 855
826=cut 856=cut
827 857
828our $safe = new Safe "safe"; 858our $safe = new Safe "safe";
829our $safe_hole = new Safe::Hole; 859our $safe_hole = new Safe::Hole;
… …
965 995
966Immediately write the database to disk I<if it is dirty>. 996Immediately write the database to disk I<if it is dirty>.
967 997
968=cut 998=cut
969 999
1000our $DB;
1001
970{ 1002{
971 my $db;
972 my $path = cf::localdir . "/database.pst"; 1003 my $path = cf::localdir . "/database.pst";
973 1004
974 sub db_load() { 1005 sub db_load() {
975 warn "loading database $path\n";#d# remove later 1006 warn "loading database $path\n";#d# remove later
976 $db = stat $path ? Storable::retrieve $path : { }; 1007 $DB = stat $path ? Storable::retrieve $path : { };
977 } 1008 }
978 1009
979 my $pid; 1010 my $pid;
980 1011
981 sub db_save() { 1012 sub db_save() {
982 warn "saving database $path\n";#d# remove later 1013 warn "saving database $path\n";#d# remove later
983 waitpid $pid, 0 if $pid; 1014 waitpid $pid, 0 if $pid;
984 if (0 == ($pid = fork)) { 1015 if (0 == ($pid = fork)) {
985 $db->{_meta}{version} = 1; 1016 $DB->{_meta}{version} = 1;
986 Storable::nstore $db, "$path~"; 1017 Storable::nstore $DB, "$path~";
987 rename "$path~", $path; 1018 rename "$path~", $path;
988 cf::_exit 0 if defined $pid; 1019 cf::_exit 0 if defined $pid;
989 } 1020 }
990 } 1021 }
991 1022
… …
1005 $idle->start; 1036 $idle->start;
1006 } 1037 }
1007 1038
1008 sub db_get($;$) { 1039 sub db_get($;$) {
1009 @_ >= 2 1040 @_ >= 2
1010 ? $db->{$_[0]}{$_[1]} 1041 ? $DB->{$_[0]}{$_[1]}
1011 : ($db->{$_[0]} ||= { }) 1042 : ($DB->{$_[0]} ||= { })
1012 } 1043 }
1013 1044
1014 sub db_put($$;$) { 1045 sub db_put($$;$) {
1015 if (@_ >= 3) { 1046 if (@_ >= 3) {
1016 $db->{$_[0]}{$_[1]} = $_[2]; 1047 $DB->{$_[0]}{$_[1]} = $_[2];
1017 } else { 1048 } else {
1018 $db->{$_[0]} = $_[1]; 1049 $DB->{$_[0]} = $_[1];
1019 } 1050 }
1020 db_dirty; 1051 db_dirty;
1021 } 1052 }
1022 1053
1023 attach_global 1054 attach_global
… …
1035 open my $fh, "<:utf8", cf::confdir . "/config" 1066 open my $fh, "<:utf8", cf::confdir . "/config"
1036 or return; 1067 or return;
1037 1068
1038 local $/; 1069 local $/;
1039 *CFG = YAML::Syck::Load <$fh>; 1070 *CFG = YAML::Syck::Load <$fh>;
1040
1041 use Data::Dumper; warn Dumper \%CFG;
1042} 1071}
1043 1072
1044sub main { 1073sub main {
1045 cfg_load; 1074 cfg_load;
1046 db_load; 1075 db_load;
… …
1142register "<global>", __PACKAGE__; 1171register "<global>", __PACKAGE__;
1143 1172
1144unshift @INC, $LIBDIR; 1173unshift @INC, $LIBDIR;
1145 1174
1146$TICK_WATCHER = Event->timer ( 1175$TICK_WATCHER = Event->timer (
1147 prio => 1, 1176 prio => 1,
1177 async => 1,
1148 at => $NEXT_TICK || 1, 1178 at => $NEXT_TICK || 1,
1149 cb => sub { 1179 cb => sub {
1150 cf::server_tick; # one server iteration 1180 cf::server_tick; # one server iteration
1151 1181
1152 my $NOW = Event::time; 1182 my $NOW = Event::time;
1153 $NEXT_TICK += $TICK; 1183 $NEXT_TICK += $TICK;
1154 1184
1155 # if we are delayed by four ticks, skip them all 1185 # if we are delayed by four ticks or more, skip them all
1156 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1186 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1157 1187
1158 $TICK_WATCHER->at ($NEXT_TICK); 1188 $TICK_WATCHER->at ($NEXT_TICK);
1159 $TICK_WATCHER->start; 1189 $TICK_WATCHER->start;
1160 }, 1190 },
1161); 1191);
1162 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
11631 12001
1164 1201

Diff Legend

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