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.82 by root, Sun Dec 3 20:59:52 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
… …
510 unlink $filename; 523 unlink $filename;
511 unlink "$filename.pst"; 524 unlink "$filename.pst";
512 } 525 }
513} 526}
514 527
528sub object_freezer_as_string {
529 my ($rdata, $objs) = @_;
530
531 use Data::Dumper;
532
533 $$rdata . Dumper $objs
534}
535
515sub object_thawer_load { 536sub object_thawer_load {
516 my ($filename) = @_; 537 my ($filename) = @_;
517 538
518 local $/; 539 local $/;
519 540
… …
621 . "#line 1 \"$path\"\n{\n" 642 . "#line 1 \"$path\"\n{\n"
622 . (do { local $/; <$fh> }) 643 . (do { local $/; <$fh> })
623 . "\n};\n1"; 644 . "\n};\n1";
624 645
625 eval $source 646 eval $source
626 or die "$path: $@"; 647 or die $@ ? "$path: $@\n"
648 : "extension disabled.\n";
627 649
628 push @exts, $pkg; 650 push @exts, $pkg;
629 $ext_pkg{$base} = $pkg; 651 $ext_pkg{$base} = $pkg;
630 652
631# no strict 'refs'; 653# no strict 'refs';
… …
762sub cf::player::exists($) { 784sub cf::player::exists($) {
763 cf::player::find $_[0] 785 cf::player::find $_[0]
764 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 786 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
765} 787}
766 788
767=item $player->reply ($npc, $msg[, $flags]) 789=item $player_object->reply ($npc, $msg[, $flags])
768 790
769Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 791Sends 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 792can be C<undef>. Does the right thing when the player is currently in a
771dialogue with the given NPC character. 793dialogue with the given NPC character.
772 794
… …
799 $msg{msgid} = $id; 821 $msg{msgid} = $id;
800 822
801 $self->send ("ext " . to_json \%msg); 823 $self->send ("ext " . to_json \%msg);
802} 824}
803 825
804=back 826=item $player_object->may ("access")
827
828Returns wether the given player is authorized to access resource "access"
829(e.g. "command_wizcast").
830
831=cut
832
833sub cf::object::player::may {
834 my ($self, $access) = @_;
835
836 $self->flag (cf::FLAG_WIZ) ||
837 (ref $cf::CFG{"may_$access"}
838 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
839 : $cf::CFG{"may_$access"})
840}
805 841
806=cut 842=cut
807 843
808############################################################################# 844#############################################################################
809 845
… …
811 847
812Functions that provide a safe environment to compile and execute 848Functions that provide a safe environment to compile and execute
813snippets of perl code without them endangering the safety of the server 849snippets of perl code without them endangering the safety of the server
814itself. Looping constructs, I/O operators and other built-in functionality 850itself. Looping constructs, I/O operators and other built-in functionality
815is not available in the safe scripting environment, and the number of 851is not available in the safe scripting environment, and the number of
816functions and methods that cna be called is greatly reduced. 852functions and methods that can be called is greatly reduced.
817 853
818=cut 854=cut
819 855
820our $safe = new Safe "safe"; 856our $safe = new Safe "safe";
821our $safe_hole = new Safe::Hole; 857our $safe_hole = new Safe::Hole;
… …
912 *{"safe::$fun"} = $safe_hole->wrap ($cb); 948 *{"safe::$fun"} = $safe_hole->wrap ($cb);
913} 949}
914 950
915=back 951=back
916 952
953=cut
954
917############################################################################# 955#############################################################################
918 956
919=head2 EXTENSION DATABASE SUPPORT 957=head2 EXTENSION DATABASE SUPPORT
920 958
921Crossfire maintains a very simple database for extension use. It can 959Crossfire maintains a very simple database for extension use. It can
… …
955 993
956Immediately write the database to disk I<if it is dirty>. 994Immediately write the database to disk I<if it is dirty>.
957 995
958=cut 996=cut
959 997
998our $DB;
999
960{ 1000{
961 my $db;
962 my $path = cf::localdir . "/database.pst"; 1001 my $path = cf::localdir . "/database.pst";
963 1002
964 sub db_load() { 1003 sub db_load() {
965 warn "loading database $path\n";#d# remove later 1004 warn "loading database $path\n";#d# remove later
966 $db = stat $path ? Storable::retrieve $path : { }; 1005 $DB = stat $path ? Storable::retrieve $path : { };
967 } 1006 }
968 1007
969 my $pid; 1008 my $pid;
970 1009
971 sub db_save() { 1010 sub db_save() {
972 warn "saving database $path\n";#d# remove later 1011 warn "saving database $path\n";#d# remove later
973 waitpid $pid, 0 if $pid; 1012 waitpid $pid, 0 if $pid;
974 if (0 == ($pid = fork)) { 1013 if (0 == ($pid = fork)) {
975 $db->{_meta}{version} = 1; 1014 $DB->{_meta}{version} = 1;
976 Storable::nstore $db, "$path~"; 1015 Storable::nstore $DB, "$path~";
977 rename "$path~", $path; 1016 rename "$path~", $path;
978 cf::_exit 0 if defined $pid; 1017 cf::_exit 0 if defined $pid;
979 } 1018 }
980 } 1019 }
981 1020
… …
995 $idle->start; 1034 $idle->start;
996 } 1035 }
997 1036
998 sub db_get($;$) { 1037 sub db_get($;$) {
999 @_ >= 2 1038 @_ >= 2
1000 ? $db->{$_[0]}{$_[1]} 1039 ? $DB->{$_[0]}{$_[1]}
1001 : ($db->{$_[0]} ||= { }) 1040 : ($DB->{$_[0]} ||= { })
1002 } 1041 }
1003 1042
1004 sub db_put($$;$) { 1043 sub db_put($$;$) {
1005 if (@_ >= 3) { 1044 if (@_ >= 3) {
1006 $db->{$_[0]}{$_[1]} = $_[2]; 1045 $DB->{$_[0]}{$_[1]} = $_[2];
1007 } else { 1046 } else {
1008 $db->{$_[0]} = $_[1]; 1047 $DB->{$_[0]} = $_[1];
1009 } 1048 }
1010 db_dirty; 1049 db_dirty;
1011 } 1050 }
1012 1051
1013 attach_global 1052 attach_global
… …
1019} 1058}
1020 1059
1021############################################################################# 1060#############################################################################
1022# the server's main() 1061# the server's main()
1023 1062
1063sub cfg_load {
1064 open my $fh, "<:utf8", cf::confdir . "/config"
1065 or return;
1066
1067 local $/;
1068 *CFG = YAML::Syck::Load <$fh>;
1069}
1070
1024sub main { 1071sub main {
1072 cfg_load;
1025 db_load; 1073 db_load;
1026 load_extensions; 1074 load_extensions;
1027 Event::loop; 1075 Event::loop;
1028} 1076}
1029 1077
… …
1081 1129
1082 # reload cf.pm 1130 # reload cf.pm
1083 $msg->("reloading cf.pm"); 1131 $msg->("reloading cf.pm");
1084 require cf; 1132 require cf;
1085 1133
1086 # load database again 1134 # load config and database again
1135 cf::cfg_load;
1087 cf::db_load; 1136 cf::db_load;
1088 1137
1089 # load extensions 1138 # load extensions
1090 $msg->("load extensions"); 1139 $msg->("load extensions");
1091 cf::load_extensions; 1140 cf::load_extensions;
… …
1120register "<global>", __PACKAGE__; 1169register "<global>", __PACKAGE__;
1121 1170
1122unshift @INC, $LIBDIR; 1171unshift @INC, $LIBDIR;
1123 1172
1124$TICK_WATCHER = Event->timer ( 1173$TICK_WATCHER = Event->timer (
1125 prio => 1, 1174 prio => 1,
1175 async => 1,
1126 at => $NEXT_TICK || 1, 1176 at => $NEXT_TICK || 1,
1127 cb => sub { 1177 cb => sub {
1128 cf::server_tick; # one server iteration 1178 cf::server_tick; # one server iteration
1129 1179
1130 my $NOW = Event::time; 1180 my $NOW = Event::time;
1131 $NEXT_TICK += $TICK; 1181 $NEXT_TICK += $TICK;
1132 1182
1133 # if we are delayed by four ticks, skip them all 1183 # if we are delayed by four ticks or more, skip them all
1134 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1184 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1135 1185
1136 $TICK_WATCHER->at ($NEXT_TICK); 1186 $TICK_WATCHER->at ($NEXT_TICK);
1137 $TICK_WATCHER->start; 1187 $TICK_WATCHER->start;
1138 }, 1188 },
1139); 1189);
1140 1190
1191IO::AIO::max_poll_time $TICK * 0.2;
1192
1193Event->io (fd => IO::AIO::poll_fileno,
1194 poll => 'r',
1195 prio => 5,
1196 cb => \&IO::AIO::poll_cb);
1197
11411 11981
1142 1199

Diff Legend

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