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.70 by root, Sun Oct 1 10:55:37 2006 UTC vs.
Revision 1.79 by root, Tue Nov 7 14:58:35 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 = ();
… …
22our $TICK = MAX_TIME * 1e-6; 27our $TICK = MAX_TIME * 1e-6;
23our $TICK_WATCHER; 28our $TICK_WATCHER;
24our $NEXT_TICK; 29our $NEXT_TICK;
25 30
26our %CFG; 31our %CFG;
32
33our $uptime;
34
35$uptime ||= time;
27 36
28############################################################################# 37#############################################################################
29 38
30=head2 GLOBAL VARIABLES 39=head2 GLOBAL VARIABLES
31 40
… …
108 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 117 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
109 JSON::Syck::Dump $_[0] 118 JSON::Syck::Dump $_[0]
110} 119}
111 120
112=back 121=back
122
123=cut
113 124
114############################################################################# 125#############################################################################
115 126
116=head2 EVENTS AND OBJECT ATTACHMENTS 127=head2 EVENTS AND OBJECT ATTACHMENTS
117 128
… …
420This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be 431This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
421removed in future versions), and there is no public API to access override 432removed in future versions), and there is no public API to access override
422results (if you must, access C<@cf::invoke_results> directly). 433results (if you must, access C<@cf::invoke_results> directly).
423 434
424=back 435=back
436
437=cut
425 438
426############################################################################# 439#############################################################################
427 440
428=head2 METHODS VALID FOR ALL CORE OBJECTS 441=head2 METHODS VALID FOR ALL CORE OBJECTS
429 442
… …
762sub cf::player::exists($) { 775sub cf::player::exists($) {
763 cf::player::find $_[0] 776 cf::player::find $_[0]
764 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 777 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
765} 778}
766 779
767=item $player->reply ($npc, $msg[, $flags]) 780=item $player_object->reply ($npc, $msg[, $flags])
768 781
769Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 782Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
770can be C<undef>. Does the right thing when the player is currently in a 783can be C<undef>. Does the right thing when the player is currently in a
771dialogue with the given NPC character. 784dialogue with the given NPC character.
772 785
… …
799 $msg{msgid} = $id; 812 $msg{msgid} = $id;
800 813
801 $self->send ("ext " . to_json \%msg); 814 $self->send ("ext " . to_json \%msg);
802} 815}
803 816
804=back 817=item $player_object->may ("access")
818
819Returns wether the given player is authorized to access resource "access"
820(e.g. "command_wizcast").
821
822=cut
823
824sub cf::object::player::may {
825 my ($self, $access) = @_;
826
827 $self->flag (cf::FLAG_WIZ) ||
828 (ref $cf::CFG{"may_$access"}
829 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
830 : $cf::CFG{"may_$access"})
831}
805 832
806=cut 833=cut
807 834
808############################################################################# 835#############################################################################
809 836
… …
811 838
812Functions that provide a safe environment to compile and execute 839Functions that provide a safe environment to compile and execute
813snippets of perl code without them endangering the safety of the server 840snippets of perl code without them endangering the safety of the server
814itself. Looping constructs, I/O operators and other built-in functionality 841itself. Looping constructs, I/O operators and other built-in functionality
815is not available in the safe scripting environment, and the number of 842is not available in the safe scripting environment, and the number of
816functions and methods that cna be called is greatly reduced. 843functions and methods that can be called is greatly reduced.
817 844
818=cut 845=cut
819 846
820our $safe = new Safe "safe"; 847our $safe = new Safe "safe";
821our $safe_hole = new Safe::Hole; 848our $safe_hole = new Safe::Hole;
… …
912 *{"safe::$fun"} = $safe_hole->wrap ($cb); 939 *{"safe::$fun"} = $safe_hole->wrap ($cb);
913} 940}
914 941
915=back 942=back
916 943
944=cut
945
917############################################################################# 946#############################################################################
918 947
919=head2 EXTENSION DATABASE SUPPORT 948=head2 EXTENSION DATABASE SUPPORT
920 949
921Crossfire maintains a very simple database for extension use. It can 950Crossfire maintains a very simple database for extension use. It can
… …
955 984
956Immediately write the database to disk I<if it is dirty>. 985Immediately write the database to disk I<if it is dirty>.
957 986
958=cut 987=cut
959 988
989our $DB;
990
960{ 991{
961 my $db;
962 my $path = cf::localdir . "/database.pst"; 992 my $path = cf::localdir . "/database.pst";
963 993
964 sub db_load() { 994 sub db_load() {
965 warn "loading database $path\n";#d# remove later 995 warn "loading database $path\n";#d# remove later
966 $db = stat $path ? Storable::retrieve $path : { }; 996 $DB = stat $path ? Storable::retrieve $path : { };
967 } 997 }
968 998
969 my $pid; 999 my $pid;
970 1000
971 sub db_save() { 1001 sub db_save() {
972 warn "saving database $path\n";#d# remove later 1002 warn "saving database $path\n";#d# remove later
973 waitpid $pid, 0 if $pid; 1003 waitpid $pid, 0 if $pid;
974 if (0 == ($pid = fork)) { 1004 if (0 == ($pid = fork)) {
975 $db->{_meta}{version} = 1; 1005 $DB->{_meta}{version} = 1;
976 Storable::nstore $db, "$path~"; 1006 Storable::nstore $DB, "$path~";
977 rename "$path~", $path; 1007 rename "$path~", $path;
978 cf::_exit 0 if defined $pid; 1008 cf::_exit 0 if defined $pid;
979 } 1009 }
980 } 1010 }
981 1011
… …
995 $idle->start; 1025 $idle->start;
996 } 1026 }
997 1027
998 sub db_get($;$) { 1028 sub db_get($;$) {
999 @_ >= 2 1029 @_ >= 2
1000 ? $db->{$_[0]}{$_[1]} 1030 ? $DB->{$_[0]}{$_[1]}
1001 : ($db->{$_[0]} ||= { }) 1031 : ($DB->{$_[0]} ||= { })
1002 } 1032 }
1003 1033
1004 sub db_put($$;$) { 1034 sub db_put($$;$) {
1005 if (@_ >= 3) { 1035 if (@_ >= 3) {
1006 $db->{$_[0]}{$_[1]} = $_[2]; 1036 $DB->{$_[0]}{$_[1]} = $_[2];
1007 } else { 1037 } else {
1008 $db->{$_[0]} = $_[1]; 1038 $DB->{$_[0]} = $_[1];
1009 } 1039 }
1010 db_dirty; 1040 db_dirty;
1011 } 1041 }
1012 1042
1013 attach_global 1043 attach_global
… …
1019} 1049}
1020 1050
1021############################################################################# 1051#############################################################################
1022# the server's main() 1052# the server's main()
1023 1053
1054sub cfg_load {
1055 open my $fh, "<:utf8", cf::confdir . "/config"
1056 or return;
1057
1058 local $/;
1059 *CFG = YAML::Syck::Load <$fh>;
1060}
1061
1024sub main { 1062sub main {
1063 cfg_load;
1025 db_load; 1064 db_load;
1026 load_extensions; 1065 load_extensions;
1027 Event::loop; 1066 Event::loop;
1028} 1067}
1029 1068
… …
1081 1120
1082 # reload cf.pm 1121 # reload cf.pm
1083 $msg->("reloading cf.pm"); 1122 $msg->("reloading cf.pm");
1084 require cf; 1123 require cf;
1085 1124
1086 # load database again 1125 # load config and database again
1126 cf::cfg_load;
1087 cf::db_load; 1127 cf::db_load;
1088 1128
1089 # load extensions 1129 # load extensions
1090 $msg->("load extensions"); 1130 $msg->("load extensions");
1091 cf::load_extensions; 1131 cf::load_extensions;
… …
1120register "<global>", __PACKAGE__; 1160register "<global>", __PACKAGE__;
1121 1161
1122unshift @INC, $LIBDIR; 1162unshift @INC, $LIBDIR;
1123 1163
1124$TICK_WATCHER = Event->timer ( 1164$TICK_WATCHER = Event->timer (
1125 prio => 1, 1165 prio => 1,
1166 async => 1,
1126 at => $NEXT_TICK || 1, 1167 at => $NEXT_TICK || 1,
1127 cb => sub { 1168 cb => sub {
1128 cf::server_tick; # one server iteration 1169 cf::server_tick; # one server iteration
1129 1170
1130 my $NOW = Event::time; 1171 my $NOW = Event::time;
1131 $NEXT_TICK += $TICK; 1172 $NEXT_TICK += $TICK;
1132 1173
1133 # if we are delayed by four ticks, skip them all 1174 # if we are delayed by four ticks or more, skip them all
1134 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1175 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1135 1176
1136 $TICK_WATCHER->at ($NEXT_TICK); 1177 $TICK_WATCHER->at ($NEXT_TICK);
1137 $TICK_WATCHER->start; 1178 $TICK_WATCHER->start;
1138 }, 1179 },
1139); 1180);
1140 1181
1182eval { IO::AIO::max_poll_time $TICK * 0.2 }; #d# remove eval after restart
1183
1184Event->io (fd => IO::AIO::poll_fileno,
1185 poll => 'r',
1186 prio => 5,
1187 cb => \&IO::AIO::poll_cb);
1188
11411 11891
1142 1190

Diff Legend

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