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

Diff Legend

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