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.74 by root, Sun Oct 1 15:59:29 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
… …
1140register "<global>", __PACKAGE__; 1171register "<global>", __PACKAGE__;
1141 1172
1142unshift @INC, $LIBDIR; 1173unshift @INC, $LIBDIR;
1143 1174
1144$TICK_WATCHER = Event->timer ( 1175$TICK_WATCHER = Event->timer (
1145 prio => 1, 1176 prio => 1,
1177 async => 1,
1146 at => $NEXT_TICK || 1, 1178 at => $NEXT_TICK || 1,
1147 cb => sub { 1179 cb => sub {
1148 cf::server_tick; # one server iteration 1180 cf::server_tick; # one server iteration
1149 1181
1150 my $NOW = Event::time; 1182 my $NOW = Event::time;
1151 $NEXT_TICK += $TICK; 1183 $NEXT_TICK += $TICK;
1152 1184
1153 # if we are delayed by four ticks, skip them all 1185 # if we are delayed by four ticks or more, skip them all
1154 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1186 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1155 1187
1156 $TICK_WATCHER->at ($NEXT_TICK); 1188 $TICK_WATCHER->at ($NEXT_TICK);
1157 $TICK_WATCHER->start; 1189 $TICK_WATCHER->start;
1158 }, 1190 },
1159); 1191);
1160 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
11611 12001
1162 1201

Diff Legend

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