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

Diff Legend

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