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

Diff Legend

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