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.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 ();
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 = ();
… …
23our $TICK_WATCHER; 28our $TICK_WATCHER;
24our $NEXT_TICK; 29our $NEXT_TICK;
25 30
26our %CFG; 31our %CFG;
27 32
33our $uptime;#d#
34our $UPTIME;
35$UPTIME ||= $uptime;#d#
36$UPTIME ||= time;
37
28############################################################################# 38#############################################################################
29 39
30=head2 GLOBAL VARIABLES 40=head2 GLOBAL VARIABLES
31 41
32=over 4 42=over 4
43
44=item $cf::UPTIME
45
46The timestamp of the server start (so not actually an uptime).
33 47
34=item $cf::LIBDIR 48=item $cf::LIBDIR
35 49
36The perl library directory, where extensions and cf-specific modules can 50The perl library directory, where extensions and cf-specific modules can
37be found. It will be added to C<@INC> automatically. 51be found. It will be added to C<@INC> automatically.
… …
108 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 122 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
109 JSON::Syck::Dump $_[0] 123 JSON::Syck::Dump $_[0]
110} 124}
111 125
112=back 126=back
127
128=cut
113 129
114############################################################################# 130#############################################################################
115 131
116=head2 EVENTS AND OBJECT ATTACHMENTS 132=head2 EVENTS AND OBJECT ATTACHMENTS
117 133
… …
420This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be 436This 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 437removed in future versions), and there is no public API to access override
422results (if you must, access C<@cf::invoke_results> directly). 438results (if you must, access C<@cf::invoke_results> directly).
423 439
424=back 440=back
441
442=cut
425 443
426############################################################################# 444#############################################################################
427 445
428=head2 METHODS VALID FOR ALL CORE OBJECTS 446=head2 METHODS VALID FOR ALL CORE OBJECTS
429 447
… …
510 unlink $filename; 528 unlink $filename;
511 unlink "$filename.pst"; 529 unlink "$filename.pst";
512 } 530 }
513} 531}
514 532
533sub object_freezer_as_string {
534 my ($rdata, $objs) = @_;
535
536 use Data::Dumper;
537
538 $$rdata . Dumper $objs
539}
540
515sub object_thawer_load { 541sub object_thawer_load {
516 my ($filename) = @_; 542 my ($filename) = @_;
517 543
518 local $/; 544 local $/;
519 545
… …
621 . "#line 1 \"$path\"\n{\n" 647 . "#line 1 \"$path\"\n{\n"
622 . (do { local $/; <$fh> }) 648 . (do { local $/; <$fh> })
623 . "\n};\n1"; 649 . "\n};\n1";
624 650
625 eval $source 651 eval $source
626 or die "$path: $@"; 652 or die $@ ? "$path: $@\n"
653 : "extension disabled.\n";
627 654
628 push @exts, $pkg; 655 push @exts, $pkg;
629 $ext_pkg{$base} = $pkg; 656 $ext_pkg{$base} = $pkg;
630 657
631# no strict 'refs'; 658# no strict 'refs';
… …
762sub cf::player::exists($) { 789sub cf::player::exists($) {
763 cf::player::find $_[0] 790 cf::player::find $_[0]
764 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;
765} 792}
766 793
767=item $player->reply ($npc, $msg[, $flags]) 794=item $player_object->reply ($npc, $msg[, $flags])
768 795
769Sends 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>
770can 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
771dialogue with the given NPC character. 798dialogue with the given NPC character.
772 799
… …
799 $msg{msgid} = $id; 826 $msg{msgid} = $id;
800 827
801 $self->send ("ext " . to_json \%msg); 828 $self->send ("ext " . to_json \%msg);
802} 829}
803 830
804=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}
805 846
806=cut 847=cut
807 848
808############################################################################# 849#############################################################################
809 850
… …
811 852
812Functions that provide a safe environment to compile and execute 853Functions that provide a safe environment to compile and execute
813snippets of perl code without them endangering the safety of the server 854snippets of perl code without them endangering the safety of the server
814itself. Looping constructs, I/O operators and other built-in functionality 855itself. Looping constructs, I/O operators and other built-in functionality
815is not available in the safe scripting environment, and the number of 856is not available in the safe scripting environment, and the number of
816functions and methods that cna be called is greatly reduced. 857functions and methods that can be called is greatly reduced.
817 858
818=cut 859=cut
819 860
820our $safe = new Safe "safe"; 861our $safe = new Safe "safe";
821our $safe_hole = new Safe::Hole; 862our $safe_hole = new Safe::Hole;
… …
912 *{"safe::$fun"} = $safe_hole->wrap ($cb); 953 *{"safe::$fun"} = $safe_hole->wrap ($cb);
913} 954}
914 955
915=back 956=back
916 957
958=cut
959
917############################################################################# 960#############################################################################
918 961
919=head2 EXTENSION DATABASE SUPPORT 962=head2 EXTENSION DATABASE SUPPORT
920 963
921Crossfire maintains a very simple database for extension use. It can 964Crossfire maintains a very simple database for extension use. It can
… …
955 998
956Immediately write the database to disk I<if it is dirty>. 999Immediately write the database to disk I<if it is dirty>.
957 1000
958=cut 1001=cut
959 1002
1003our $DB;
1004
960{ 1005{
961 my $db;
962 my $path = cf::localdir . "/database.pst"; 1006 my $path = cf::localdir . "/database.pst";
963 1007
964 sub db_load() { 1008 sub db_load() {
965 warn "loading database $path\n";#d# remove later 1009 warn "loading database $path\n";#d# remove later
966 $db = stat $path ? Storable::retrieve $path : { }; 1010 $DB = stat $path ? Storable::retrieve $path : { };
967 } 1011 }
968 1012
969 my $pid; 1013 my $pid;
970 1014
971 sub db_save() { 1015 sub db_save() {
972 warn "saving database $path\n";#d# remove later 1016 warn "saving database $path\n";#d# remove later
973 waitpid $pid, 0 if $pid; 1017 waitpid $pid, 0 if $pid;
974 if (0 == ($pid = fork)) { 1018 if (0 == ($pid = fork)) {
975 $db->{_meta}{version} = 1; 1019 $DB->{_meta}{version} = 1;
976 Storable::nstore $db, "$path~"; 1020 Storable::nstore $DB, "$path~";
977 rename "$path~", $path; 1021 rename "$path~", $path;
978 cf::_exit 0 if defined $pid; 1022 cf::_exit 0 if defined $pid;
979 } 1023 }
980 } 1024 }
981 1025
… …
995 $idle->start; 1039 $idle->start;
996 } 1040 }
997 1041
998 sub db_get($;$) { 1042 sub db_get($;$) {
999 @_ >= 2 1043 @_ >= 2
1000 ? $db->{$_[0]}{$_[1]} 1044 ? $DB->{$_[0]}{$_[1]}
1001 : ($db->{$_[0]} ||= { }) 1045 : ($DB->{$_[0]} ||= { })
1002 } 1046 }
1003 1047
1004 sub db_put($$;$) { 1048 sub db_put($$;$) {
1005 if (@_ >= 3) { 1049 if (@_ >= 3) {
1006 $db->{$_[0]}{$_[1]} = $_[2]; 1050 $DB->{$_[0]}{$_[1]} = $_[2];
1007 } else { 1051 } else {
1008 $db->{$_[0]} = $_[1]; 1052 $DB->{$_[0]} = $_[1];
1009 } 1053 }
1010 db_dirty; 1054 db_dirty;
1011 } 1055 }
1012 1056
1013 attach_global 1057 attach_global
… …
1019} 1063}
1020 1064
1021############################################################################# 1065#############################################################################
1022# the server's main() 1066# the server's main()
1023 1067
1068sub cfg_load {
1069 open my $fh, "<:utf8", cf::confdir . "/config"
1070 or return;
1071
1072 local $/;
1073 *CFG = YAML::Syck::Load <$fh>;
1074}
1075
1024sub main { 1076sub main {
1077 cfg_load;
1025 db_load; 1078 db_load;
1026 load_extensions; 1079 load_extensions;
1027 Event::loop; 1080 Event::loop;
1028} 1081}
1029 1082
… …
1081 1134
1082 # reload cf.pm 1135 # reload cf.pm
1083 $msg->("reloading cf.pm"); 1136 $msg->("reloading cf.pm");
1084 require cf; 1137 require cf;
1085 1138
1086 # load database again 1139 # load config and database again
1140 cf::cfg_load;
1087 cf::db_load; 1141 cf::db_load;
1088 1142
1089 # load extensions 1143 # load extensions
1090 $msg->("load extensions"); 1144 $msg->("load extensions");
1091 cf::load_extensions; 1145 cf::load_extensions;
… …
1120register "<global>", __PACKAGE__; 1174register "<global>", __PACKAGE__;
1121 1175
1122unshift @INC, $LIBDIR; 1176unshift @INC, $LIBDIR;
1123 1177
1124$TICK_WATCHER = Event->timer ( 1178$TICK_WATCHER = Event->timer (
1125 prio => 1, 1179 prio => 1,
1180 async => 1,
1126 at => $NEXT_TICK || 1, 1181 at => $NEXT_TICK || 1,
1127 cb => sub { 1182 cb => sub {
1128 cf::server_tick; # one server iteration 1183 cf::server_tick; # one server iteration
1129 1184
1130 my $NOW = Event::time; 1185 my $NOW = Event::time;
1131 $NEXT_TICK += $TICK; 1186 $NEXT_TICK += $TICK;
1132 1187
1133 # if we are delayed by four ticks, skip them all 1188 # if we are delayed by four ticks or more, skip them all
1134 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1189 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1135 1190
1136 $TICK_WATCHER->at ($NEXT_TICK); 1191 $TICK_WATCHER->at ($NEXT_TICK);
1137 $TICK_WATCHER->start; 1192 $TICK_WATCHER->start;
1138 }, 1193 },
1139); 1194);
1140 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
11411 12031
1142 1204

Diff Legend

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