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.72 by root, Sun Oct 1 11:41:37 2006 UTC vs.
Revision 1.85 by root, Mon Dec 11 22:56: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
15# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 16# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
16$YAML::Syck::ImplicitUnicode = 1; 17$YAML::Syck::ImplicitUnicode = 1;
17 18
18use strict; 19use strict;
19 20
21our %COMMAND = ();
22our %COMMAND_TIME = ();
23our %EXTCMD = ();
24
20_init_vars; 25_init_vars;
21 26
22our %COMMAND = ();
23our @EVENT; 27our @EVENT;
24our $LIBDIR = maps_directory "perl"; 28our $LIBDIR = maps_directory "perl";
25 29
26our $TICK = MAX_TIME * 1e-6; 30our $TICK = MAX_TIME * 1e-6;
27our $TICK_WATCHER; 31our $TICK_WATCHER;
28our $NEXT_TICK; 32our $NEXT_TICK;
29 33
30our %CFG; 34our %CFG;
31 35
36our $UPTIME; $UPTIME ||= time;
37
32############################################################################# 38#############################################################################
33 39
34=head2 GLOBAL VARIABLES 40=head2 GLOBAL VARIABLES
35 41
36=over 4 42=over 4
43
44=item $cf::UPTIME
45
46The timestamp of the server start (so not actually an uptime).
37 47
38=item $cf::LIBDIR 48=item $cf::LIBDIR
39 49
40The perl library directory, where extensions and cf-specific modules can 50The perl library directory, where extensions and cf-specific modules can
41be found. It will be added to C<@INC> automatically. 51be found. It will be added to C<@INC> automatically.
… …
78}; 88};
79 89
80my %ext_pkg; 90my %ext_pkg;
81my @exts; 91my @exts;
82my @hook; 92my @hook;
83my %command;
84my %extcmd;
85 93
86=head2 UTILITY FUNCTIONS 94=head2 UTILITY FUNCTIONS
87 95
88=over 4 96=over 4
89 97
… …
518 unlink $filename; 526 unlink $filename;
519 unlink "$filename.pst"; 527 unlink "$filename.pst";
520 } 528 }
521} 529}
522 530
531sub object_freezer_as_string {
532 my ($rdata, $objs) = @_;
533
534 use Data::Dumper;
535
536 $$rdata . Dumper $objs
537}
538
523sub object_thawer_load { 539sub object_thawer_load {
524 my ($filename) = @_; 540 my ($filename) = @_;
525 541
526 local $/; 542 local $/;
527 543
… …
552 if exists $src->{_attachment}; 568 if exists $src->{_attachment};
553 }, 569 },
554; 570;
555 571
556############################################################################# 572#############################################################################
557# old plug-in events 573# command handling &c
558 574
559sub inject_event { 575=item cf::register_command $name => \&callback($ob,$args);
560 my $extension = shift;
561 my $event_code = shift;
562 576
563 my $cb = $hook[$event_code]{$extension} 577Register a callback for execution when the client sends the user command
564 or return; 578$name.
565 579
566 &$cb 580=cut
567}
568
569sub inject_global_event {
570 my $event = shift;
571
572 my $cb = $hook[$event]
573 or return;
574
575 List::Util::max map &$_, values %$cb
576}
577
578sub inject_command {
579 my ($name, $obj, $params) = @_;
580
581 for my $cmd (@{ $command{$name} }) {
582 $cmd->[1]->($obj, $params);
583 }
584
585 -1
586}
587 581
588sub register_command { 582sub register_command {
589 my ($name, $time, $cb) = @_; 583 my ($name, $cb) = @_;
590 584
591 my $caller = caller; 585 my $caller = caller;
592 #warn "registering command '$name/$time' to '$caller'"; 586 #warn "registering command '$name/$time' to '$caller'";
593 587
594 push @{ $command{$name} }, [$time, $cb, $caller]; 588 push @{ $COMMAND{$name} }, [$caller, $cb];
595 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
596} 589}
590
591=item cf::register_extcmd $name => \&callback($pl,$packet);
592
593Register a callbackf ro execution when the client sends an extcmd packet.
594
595If the callback returns something, it is sent back as if reply was being
596called.
597
598=cut
597 599
598sub register_extcmd { 600sub register_extcmd {
599 my ($name, $cb) = @_; 601 my ($name, $cb) = @_;
600 602
601 my $caller = caller; 603 my $caller = caller;
602 #warn "registering extcmd '$name' to '$caller'"; 604 #warn "registering extcmd '$name' to '$caller'";
603 605
604 $extcmd{$name} = [$cb, $caller]; 606 $EXTCMD{$name} = [$cb, $caller];
605} 607}
608
609attach_to_players
610 on_command => sub {
611 my ($pl, $name, $params) = @_;
612
613 my $cb = $COMMAND{$name}
614 or return;
615
616 for my $cmd (@$cb) {
617 $cmd->[1]->($pl->ob, $params);
618 }
619
620 cf::override;
621 },
622 on_extcmd => sub {
623 my ($pl, $buf) = @_;
624
625 my $msg = eval { from_json $buf };
626
627 if (ref $msg) {
628 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
629 if (my %reply = $cb->[0]->($pl, $msg)) {
630 $pl->ext_reply ($msg->{msgid}, %reply);
631 }
632 }
633 } else {
634 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
635 }
636
637 cf::override;
638 },
639;
606 640
607sub register { 641sub register {
608 my ($base, $pkg) = @_; 642 my ($base, $pkg) = @_;
609 643
610 #TODO 644 #TODO
… …
629 . "#line 1 \"$path\"\n{\n" 663 . "#line 1 \"$path\"\n{\n"
630 . (do { local $/; <$fh> }) 664 . (do { local $/; <$fh> })
631 . "\n};\n1"; 665 . "\n};\n1";
632 666
633 eval $source 667 eval $source
634 or die "$path: $@"; 668 or die $@ ? "$path: $@\n"
669 : "extension disabled.\n";
635 670
636 push @exts, $pkg; 671 push @exts, $pkg;
637 $ext_pkg{$base} = $pkg; 672 $ext_pkg{$base} = $pkg;
638 673
639# no strict 'refs'; 674# no strict 'refs';
… …
652# for my $idx (0 .. $#PLUGIN_EVENT) { 687# for my $idx (0 .. $#PLUGIN_EVENT) {
653# delete $hook[$idx]{$pkg}; 688# delete $hook[$idx]{$pkg};
654# } 689# }
655 690
656 # remove commands 691 # remove commands
657 for my $name (keys %command) { 692 for my $name (keys %COMMAND) {
658 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 693 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
659 694
660 if (@cb) { 695 if (@cb) {
661 $command{$name} = \@cb; 696 $COMMAND{$name} = \@cb;
662 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
663 } else { 697 } else {
664 delete $command{$name};
665 delete $COMMAND{"$name\000"}; 698 delete $COMMAND{$name};
666 } 699 }
667 } 700 }
668 701
669 # remove extcmds 702 # remove extcmds
670 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 703 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
671 delete $extcmd{$name}; 704 delete $EXTCMD{$name};
672 } 705 }
673 706
674 if (my $cb = $pkg->can ("unload")) { 707 if (my $cb = $pkg->can ("unload")) {
675 eval { 708 eval {
676 $cb->($pkg); 709 $cb->($pkg);
… …
692 } or warn "$ext not loaded: $@"; 725 } or warn "$ext not loaded: $@";
693 } 726 }
694} 727}
695 728
696############################################################################# 729#############################################################################
697# extcmd framework, basically convert ext <msg>
698# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
699
700attach_to_players
701 on_extcmd => sub {
702 my ($pl, $buf) = @_;
703
704 my $msg = eval { from_json $buf };
705
706 if (ref $msg) {
707 if (my $cb = $extcmd{$msg->{msgtype}}) {
708 if (my %reply = $cb->[0]->($pl, $msg)) {
709 $pl->ext_reply ($msg->{msgid}, %reply);
710 }
711 }
712 } else {
713 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
714 }
715
716 cf::override;
717 },
718;
719
720#############################################################################
721# load/save/clean perl data associated with a map 730# load/save/clean perl data associated with a map
722 731
723*cf::mapsupport::on_clean = sub { 732*cf::mapsupport::on_clean = sub {
724 my ($map) = @_; 733 my ($map) = @_;
725 734
… …
770sub cf::player::exists($) { 779sub cf::player::exists($) {
771 cf::player::find $_[0] 780 cf::player::find $_[0]
772 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 781 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
773} 782}
774 783
775=item $player->reply ($npc, $msg[, $flags]) 784=item $player_object->reply ($npc, $msg[, $flags])
776 785
777Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 786Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
778can be C<undef>. Does the right thing when the player is currently in a 787can be C<undef>. Does the right thing when the player is currently in a
779dialogue with the given NPC character. 788dialogue with the given NPC character.
780 789
… …
807 $msg{msgid} = $id; 816 $msg{msgid} = $id;
808 817
809 $self->send ("ext " . to_json \%msg); 818 $self->send ("ext " . to_json \%msg);
810} 819}
811 820
812=back 821=item $player_object->may ("access")
822
823Returns wether the given player is authorized to access resource "access"
824(e.g. "command_wizcast").
825
826=cut
827
828sub cf::object::player::may {
829 my ($self, $access) = @_;
830
831 $self->flag (cf::FLAG_WIZ) ||
832 (ref $cf::CFG{"may_$access"}
833 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
834 : $cf::CFG{"may_$access"})
835}
813 836
814=cut 837=cut
815 838
816############################################################################# 839#############################################################################
817 840
… …
819 842
820Functions that provide a safe environment to compile and execute 843Functions that provide a safe environment to compile and execute
821snippets of perl code without them endangering the safety of the server 844snippets of perl code without them endangering the safety of the server
822itself. Looping constructs, I/O operators and other built-in functionality 845itself. Looping constructs, I/O operators and other built-in functionality
823is not available in the safe scripting environment, and the number of 846is not available in the safe scripting environment, and the number of
824functions and methods that cna be called is greatly reduced. 847functions and methods that can be called is greatly reduced.
825 848
826=cut 849=cut
827 850
828our $safe = new Safe "safe"; 851our $safe = new Safe "safe";
829our $safe_hole = new Safe::Hole; 852our $safe_hole = new Safe::Hole;
… …
965 988
966Immediately write the database to disk I<if it is dirty>. 989Immediately write the database to disk I<if it is dirty>.
967 990
968=cut 991=cut
969 992
993our $DB;
994
970{ 995{
971 my $db;
972 my $path = cf::localdir . "/database.pst"; 996 my $path = cf::localdir . "/database.pst";
973 997
974 sub db_load() { 998 sub db_load() {
975 warn "loading database $path\n";#d# remove later 999 warn "loading database $path\n";#d# remove later
976 $db = stat $path ? Storable::retrieve $path : { }; 1000 $DB = stat $path ? Storable::retrieve $path : { };
977 } 1001 }
978 1002
979 my $pid; 1003 my $pid;
980 1004
981 sub db_save() { 1005 sub db_save() {
982 warn "saving database $path\n";#d# remove later 1006 warn "saving database $path\n";#d# remove later
983 waitpid $pid, 0 if $pid; 1007 waitpid $pid, 0 if $pid;
984 if (0 == ($pid = fork)) { 1008 if (0 == ($pid = fork)) {
985 $db->{_meta}{version} = 1; 1009 $DB->{_meta}{version} = 1;
986 Storable::nstore $db, "$path~"; 1010 Storable::nstore $DB, "$path~";
987 rename "$path~", $path; 1011 rename "$path~", $path;
988 cf::_exit 0 if defined $pid; 1012 cf::_exit 0 if defined $pid;
989 } 1013 }
990 } 1014 }
991 1015
… …
1005 $idle->start; 1029 $idle->start;
1006 } 1030 }
1007 1031
1008 sub db_get($;$) { 1032 sub db_get($;$) {
1009 @_ >= 2 1033 @_ >= 2
1010 ? $db->{$_[0]}{$_[1]} 1034 ? $DB->{$_[0]}{$_[1]}
1011 : ($db->{$_[0]} ||= { }) 1035 : ($DB->{$_[0]} ||= { })
1012 } 1036 }
1013 1037
1014 sub db_put($$;$) { 1038 sub db_put($$;$) {
1015 if (@_ >= 3) { 1039 if (@_ >= 3) {
1016 $db->{$_[0]}{$_[1]} = $_[2]; 1040 $DB->{$_[0]}{$_[1]} = $_[2];
1017 } else { 1041 } else {
1018 $db->{$_[0]} = $_[1]; 1042 $DB->{$_[0]} = $_[1];
1019 } 1043 }
1020 db_dirty; 1044 db_dirty;
1021 } 1045 }
1022 1046
1023 attach_global 1047 attach_global
… …
1029} 1053}
1030 1054
1031############################################################################# 1055#############################################################################
1032# the server's main() 1056# the server's main()
1033 1057
1034sub load_cfg { 1058sub cfg_load {
1035 open my $fh, "<:utf8", cf::confdir . "/config" 1059 open my $fh, "<:utf8", cf::confdir . "/config"
1036 or return; 1060 or return;
1037 1061
1038 local $/; 1062 local $/;
1039 *CFG = YAML::Syck::Load <$fh>; 1063 *CFG = YAML::Syck::Load <$fh>;
1040
1041 use Data::Dumper; warn Dumper \%CFG;
1042} 1064}
1043 1065
1044sub main { 1066sub main {
1045 load_cfg; 1067 cfg_load;
1046 db_load; 1068 db_load;
1047 load_extensions; 1069 load_extensions;
1048 Event::loop; 1070 Event::loop;
1049} 1071}
1050 1072
… …
1102 1124
1103 # reload cf.pm 1125 # reload cf.pm
1104 $msg->("reloading cf.pm"); 1126 $msg->("reloading cf.pm");
1105 require cf; 1127 require cf;
1106 1128
1107 # load database again 1129 # load config and database again
1130 cf::cfg_load;
1108 cf::db_load; 1131 cf::db_load;
1109 1132
1110 # load extensions 1133 # load extensions
1111 $msg->("load extensions"); 1134 $msg->("load extensions");
1112 cf::load_extensions; 1135 cf::load_extensions;
… …
1125 warn $_[0]; 1148 warn $_[0];
1126 print "$_[0]\n"; 1149 print "$_[0]\n";
1127 }; 1150 };
1128} 1151}
1129 1152
1153register "<global>", __PACKAGE__;
1154
1130register_command "perl-reload", 0, sub { 1155register_command "perl-reload" => sub {
1131 my ($who, $arg) = @_; 1156 my ($who, $arg) = @_;
1132 1157
1133 if ($who->flag (FLAG_WIZ)) { 1158 if ($who->flag (FLAG_WIZ)) {
1134 _perl_reload { 1159 _perl_reload {
1135 warn $_[0]; 1160 warn $_[0];
1136 $who->message ($_[0]); 1161 $who->message ($_[0]);
1137 }; 1162 };
1138 } 1163 }
1139}; 1164};
1140 1165
1141register "<global>", __PACKAGE__;
1142
1143unshift @INC, $LIBDIR; 1166unshift @INC, $LIBDIR;
1144 1167
1145$TICK_WATCHER = Event->timer ( 1168$TICK_WATCHER = Event->timer (
1146 prio => 1, 1169 prio => 1,
1170 async => 1,
1147 at => $NEXT_TICK || 1, 1171 at => $NEXT_TICK || 1,
1148 cb => sub { 1172 cb => sub {
1149 cf::server_tick; # one server iteration 1173 cf::server_tick; # one server iteration
1150 1174
1151 my $NOW = Event::time; 1175 my $NOW = Event::time;
1152 $NEXT_TICK += $TICK; 1176 $NEXT_TICK += $TICK;
1153 1177
1154 # if we are delayed by four ticks, skip them all 1178 # if we are delayed by four ticks or more, skip them all
1155 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1179 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1156 1180
1157 $TICK_WATCHER->at ($NEXT_TICK); 1181 $TICK_WATCHER->at ($NEXT_TICK);
1158 $TICK_WATCHER->start; 1182 $TICK_WATCHER->start;
1159 }, 1183 },
1160); 1184);
1161 1185
1186IO::AIO::max_poll_time $TICK * 0.2;
1187
1188Event->io (fd => IO::AIO::poll_fileno,
1189 poll => 'r',
1190 prio => 5,
1191 cb => \&IO::AIO::poll_cb);
1192
11621 11931
1163 1194

Diff Legend

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