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.89 by root, Fri Dec 15 19:59:20 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
21sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
22
23our %COMMAND = ();
24our %COMMAND_TIME = ();
25our %EXTCMD = ();
26
20_init_vars; 27_init_vars;
21 28
22our %COMMAND = ();
23our @EVENT; 29our @EVENT;
24our $LIBDIR = maps_directory "perl"; 30our $LIBDIR = datadir . "/ext";
25 31
26our $TICK = MAX_TIME * 1e-6; 32our $TICK = MAX_TIME * 1e-6;
27our $TICK_WATCHER; 33our $TICK_WATCHER;
28our $NEXT_TICK; 34our $NEXT_TICK;
29 35
30our %CFG; 36our %CFG;
31 37
38our $UPTIME; $UPTIME ||= time;
39
32############################################################################# 40#############################################################################
33 41
34=head2 GLOBAL VARIABLES 42=head2 GLOBAL VARIABLES
35 43
36=over 4 44=over 4
45
46=item $cf::UPTIME
47
48The timestamp of the server start (so not actually an uptime).
37 49
38=item $cf::LIBDIR 50=item $cf::LIBDIR
39 51
40The perl library directory, where extensions and cf-specific modules can 52The perl library directory, where extensions and cf-specific modules can
41be found. It will be added to C<@INC> automatically. 53be found. It will be added to C<@INC> automatically.
… …
66 78
67@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 79@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
68 80
69# we bless all objects into (empty) derived classes to force a method lookup 81# we bless all objects into (empty) derived classes to force a method lookup
70# within the Safe compartment. 82# within the Safe compartment.
71for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) { 83for my $pkg (qw(
84 cf::object cf::object::player
85 cf::client cf::player
86 cf::arch cf::living
87 cf::map cf::party cf::region
88)) {
72 no strict 'refs'; 89 no strict 'refs';
73 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 90 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
74} 91}
75 92
76$Event::DIED = sub { 93$Event::DIED = sub {
… …
78}; 95};
79 96
80my %ext_pkg; 97my %ext_pkg;
81my @exts; 98my @exts;
82my @hook; 99my @hook;
83my %command;
84my %extcmd;
85 100
86=head2 UTILITY FUNCTIONS 101=head2 UTILITY FUNCTIONS
87 102
88=over 4 103=over 4
89 104
… …
518 unlink $filename; 533 unlink $filename;
519 unlink "$filename.pst"; 534 unlink "$filename.pst";
520 } 535 }
521} 536}
522 537
538sub object_freezer_as_string {
539 my ($rdata, $objs) = @_;
540
541 use Data::Dumper;
542
543 $$rdata . Dumper $objs
544}
545
523sub object_thawer_load { 546sub object_thawer_load {
524 my ($filename) = @_; 547 my ($filename) = @_;
525 548
526 local $/; 549 local $/;
527 550
… …
552 if exists $src->{_attachment}; 575 if exists $src->{_attachment};
553 }, 576 },
554; 577;
555 578
556############################################################################# 579#############################################################################
557# old plug-in events 580# command handling &c
558 581
559sub inject_event { 582=item cf::register_command $name => \&callback($ob,$args);
560 my $extension = shift;
561 my $event_code = shift;
562 583
563 my $cb = $hook[$event_code]{$extension} 584Register a callback for execution when the client sends the user command
564 or return; 585$name.
565 586
566 &$cb 587=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 588
588sub register_command { 589sub register_command {
589 my ($name, $time, $cb) = @_; 590 my ($name, $cb) = @_;
590 591
591 my $caller = caller; 592 my $caller = caller;
592 #warn "registering command '$name/$time' to '$caller'"; 593 #warn "registering command '$name/$time' to '$caller'";
593 594
594 push @{ $command{$name} }, [$time, $cb, $caller]; 595 push @{ $COMMAND{$name} }, [$caller, $cb];
595 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
596} 596}
597
598=item cf::register_extcmd $name => \&callback($pl,$packet);
599
600Register a callbackf ro execution when the client sends an extcmd packet.
601
602If the callback returns something, it is sent back as if reply was being
603called.
604
605=cut
597 606
598sub register_extcmd { 607sub register_extcmd {
599 my ($name, $cb) = @_; 608 my ($name, $cb) = @_;
600 609
601 my $caller = caller; 610 my $caller = caller;
602 #warn "registering extcmd '$name' to '$caller'"; 611 #warn "registering extcmd '$name' to '$caller'";
603 612
604 $extcmd{$name} = [$cb, $caller]; 613 $EXTCMD{$name} = [$cb, $caller];
605} 614}
615
616attach_to_players
617 on_command => sub {
618 my ($pl, $name, $params) = @_;
619
620 my $cb = $COMMAND{$name}
621 or return;
622
623 for my $cmd (@$cb) {
624 $cmd->[1]->($pl->ob, $params);
625 }
626
627 cf::override;
628 },
629 on_extcmd => sub {
630 my ($pl, $buf) = @_;
631
632 my $msg = eval { from_json $buf };
633
634 if (ref $msg) {
635 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
636 if (my %reply = $cb->[0]->($pl, $msg)) {
637 $pl->ext_reply ($msg->{msgid}, %reply);
638 }
639 }
640 } else {
641 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
642 }
643
644 cf::override;
645 },
646;
606 647
607sub register { 648sub register {
608 my ($base, $pkg) = @_; 649 my ($base, $pkg) = @_;
609 650
610 #TODO 651 #TODO
… …
629 . "#line 1 \"$path\"\n{\n" 670 . "#line 1 \"$path\"\n{\n"
630 . (do { local $/; <$fh> }) 671 . (do { local $/; <$fh> })
631 . "\n};\n1"; 672 . "\n};\n1";
632 673
633 eval $source 674 eval $source
634 or die "$path: $@"; 675 or die $@ ? "$path: $@\n"
676 : "extension disabled.\n";
635 677
636 push @exts, $pkg; 678 push @exts, $pkg;
637 $ext_pkg{$base} = $pkg; 679 $ext_pkg{$base} = $pkg;
638 680
639# no strict 'refs'; 681# no strict 'refs';
… …
652# for my $idx (0 .. $#PLUGIN_EVENT) { 694# for my $idx (0 .. $#PLUGIN_EVENT) {
653# delete $hook[$idx]{$pkg}; 695# delete $hook[$idx]{$pkg};
654# } 696# }
655 697
656 # remove commands 698 # remove commands
657 for my $name (keys %command) { 699 for my $name (keys %COMMAND) {
658 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 700 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
659 701
660 if (@cb) { 702 if (@cb) {
661 $command{$name} = \@cb; 703 $COMMAND{$name} = \@cb;
662 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
663 } else { 704 } else {
664 delete $command{$name};
665 delete $COMMAND{"$name\000"}; 705 delete $COMMAND{$name};
666 } 706 }
667 } 707 }
668 708
669 # remove extcmds 709 # remove extcmds
670 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 710 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
671 delete $extcmd{$name}; 711 delete $EXTCMD{$name};
672 } 712 }
673 713
674 if (my $cb = $pkg->can ("unload")) { 714 if (my $cb = $pkg->can ("unload")) {
675 eval { 715 eval {
676 $cb->($pkg); 716 $cb->($pkg);
… …
680 720
681 Symbol::delete_package $pkg; 721 Symbol::delete_package $pkg;
682} 722}
683 723
684sub load_extensions { 724sub load_extensions {
685 my $LIBDIR = maps_directory "perl";
686
687 for my $ext (<$LIBDIR/*.ext>) { 725 for my $ext (<$LIBDIR/*.ext>) {
688 next unless -r $ext; 726 next unless -r $ext;
689 eval { 727 eval {
690 load_extension $ext; 728 load_extension $ext;
691 1 729 1
692 } or warn "$ext not loaded: $@"; 730 } or warn "$ext not loaded: $@";
693 } 731 }
694} 732}
695 733
696############################################################################# 734#############################################################################
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 735# load/save/clean perl data associated with a map
722 736
723*cf::mapsupport::on_clean = sub { 737*cf::mapsupport::on_clean = sub {
724 my ($map) = @_; 738 my ($map) = @_;
725 739
… …
770sub cf::player::exists($) { 784sub cf::player::exists($) {
771 cf::player::find $_[0] 785 cf::player::find $_[0]
772 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;
773} 787}
774 788
775=item $player->reply ($npc, $msg[, $flags]) 789=item $player_object->reply ($npc, $msg[, $flags])
776 790
777Sends 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>
778can 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
779dialogue with the given NPC character. 793dialogue with the given NPC character.
780 794
… …
807 $msg{msgid} = $id; 821 $msg{msgid} = $id;
808 822
809 $self->send ("ext " . to_json \%msg); 823 $self->send ("ext " . to_json \%msg);
810} 824}
811 825
812=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}
813 841
814=cut 842=cut
815 843
816############################################################################# 844#############################################################################
817 845
… …
819 847
820Functions that provide a safe environment to compile and execute 848Functions that provide a safe environment to compile and execute
821snippets of perl code without them endangering the safety of the server 849snippets of perl code without them endangering the safety of the server
822itself. Looping constructs, I/O operators and other built-in functionality 850itself. Looping constructs, I/O operators and other built-in functionality
823is not available in the safe scripting environment, and the number of 851is not available in the safe scripting environment, and the number of
824functions and methods that cna be called is greatly reduced. 852functions and methods that can be called is greatly reduced.
825 853
826=cut 854=cut
827 855
828our $safe = new Safe "safe"; 856our $safe = new Safe "safe";
829our $safe_hole = new Safe::Hole; 857our $safe_hole = new Safe::Hole;
… …
965 993
966Immediately write the database to disk I<if it is dirty>. 994Immediately write the database to disk I<if it is dirty>.
967 995
968=cut 996=cut
969 997
998our $DB;
999
970{ 1000{
971 my $db;
972 my $path = cf::localdir . "/database.pst"; 1001 my $path = cf::localdir . "/database.pst";
973 1002
974 sub db_load() { 1003 sub db_load() {
975 warn "loading database $path\n";#d# remove later 1004 warn "loading database $path\n";#d# remove later
976 $db = stat $path ? Storable::retrieve $path : { }; 1005 $DB = stat $path ? Storable::retrieve $path : { };
977 } 1006 }
978 1007
979 my $pid; 1008 my $pid;
980 1009
981 sub db_save() { 1010 sub db_save() {
982 warn "saving database $path\n";#d# remove later 1011 warn "saving database $path\n";#d# remove later
983 waitpid $pid, 0 if $pid; 1012 waitpid $pid, 0 if $pid;
984 if (0 == ($pid = fork)) { 1013 if (0 == ($pid = fork)) {
985 $db->{_meta}{version} = 1; 1014 $DB->{_meta}{version} = 1;
986 Storable::nstore $db, "$path~"; 1015 Storable::nstore $DB, "$path~";
987 rename "$path~", $path; 1016 rename "$path~", $path;
988 cf::_exit 0 if defined $pid; 1017 cf::_exit 0 if defined $pid;
989 } 1018 }
990 } 1019 }
991 1020
… …
994 sub db_sync() { 1023 sub db_sync() {
995 db_save if $dirty; 1024 db_save if $dirty;
996 undef $dirty; 1025 undef $dirty;
997 } 1026 }
998 1027
999 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub { 1028 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1000 db_sync; 1029 db_sync;
1001 }); 1030 });
1002 1031
1003 sub db_dirty() { 1032 sub db_dirty() {
1004 $dirty = 1; 1033 $dirty = 1;
1005 $idle->start; 1034 $idle->start;
1006 } 1035 }
1007 1036
1008 sub db_get($;$) { 1037 sub db_get($;$) {
1009 @_ >= 2 1038 @_ >= 2
1010 ? $db->{$_[0]}{$_[1]} 1039 ? $DB->{$_[0]}{$_[1]}
1011 : ($db->{$_[0]} ||= { }) 1040 : ($DB->{$_[0]} ||= { })
1012 } 1041 }
1013 1042
1014 sub db_put($$;$) { 1043 sub db_put($$;$) {
1015 if (@_ >= 3) { 1044 if (@_ >= 3) {
1016 $db->{$_[0]}{$_[1]} = $_[2]; 1045 $DB->{$_[0]}{$_[1]} = $_[2];
1017 } else { 1046 } else {
1018 $db->{$_[0]} = $_[1]; 1047 $DB->{$_[0]} = $_[1];
1019 } 1048 }
1020 db_dirty; 1049 db_dirty;
1021 } 1050 }
1022 1051
1023 attach_global 1052 attach_global
… …
1029} 1058}
1030 1059
1031############################################################################# 1060#############################################################################
1032# the server's main() 1061# the server's main()
1033 1062
1034sub load_cfg { 1063sub cfg_load {
1035 open my $fh, "<:utf8", cf::confdir . "/config" 1064 open my $fh, "<:utf8", cf::confdir . "/config"
1036 or return; 1065 or return;
1037 1066
1038 local $/; 1067 local $/;
1039 *CFG = YAML::Syck::Load <$fh>; 1068 *CFG = YAML::Syck::Load <$fh>;
1040
1041 use Data::Dumper; warn Dumper \%CFG;
1042} 1069}
1043 1070
1044sub main { 1071sub main {
1045 load_cfg; 1072 cfg_load;
1046 db_load; 1073 db_load;
1047 load_extensions; 1074 load_extensions;
1048 Event::loop; 1075 Event::loop;
1049} 1076}
1050 1077
… …
1056 1083
1057 $msg->("reloading..."); 1084 $msg->("reloading...");
1058 1085
1059 eval { 1086 eval {
1060 # cancel all watchers 1087 # cancel all watchers
1061 $_->cancel for Event::all_watchers; 1088 for (Event::all_watchers) {
1089 $_->cancel if $_->data & WF_AUTOCANCEL;
1090 }
1062 1091
1063 # unload all extensions 1092 # unload all extensions
1064 for (@exts) { 1093 for (@exts) {
1065 $msg->("unloading <$_>"); 1094 $msg->("unloading <$_>");
1066 unload_extension $_; 1095 unload_extension $_;
… …
1102 1131
1103 # reload cf.pm 1132 # reload cf.pm
1104 $msg->("reloading cf.pm"); 1133 $msg->("reloading cf.pm");
1105 require cf; 1134 require cf;
1106 1135
1107 # load database again 1136 # load config and database again
1137 cf::cfg_load;
1108 cf::db_load; 1138 cf::db_load;
1109 1139
1110 # load extensions 1140 # load extensions
1111 $msg->("load extensions"); 1141 $msg->("load extensions");
1112 cf::load_extensions; 1142 cf::load_extensions;
… …
1125 warn $_[0]; 1155 warn $_[0];
1126 print "$_[0]\n"; 1156 print "$_[0]\n";
1127 }; 1157 };
1128} 1158}
1129 1159
1160register "<global>", __PACKAGE__;
1161
1130register_command "perl-reload", 0, sub { 1162register_command "perl-reload" => sub {
1131 my ($who, $arg) = @_; 1163 my ($who, $arg) = @_;
1132 1164
1133 if ($who->flag (FLAG_WIZ)) { 1165 if ($who->flag (FLAG_WIZ)) {
1134 _perl_reload { 1166 _perl_reload {
1135 warn $_[0]; 1167 warn $_[0];
1136 $who->message ($_[0]); 1168 $who->message ($_[0]);
1137 }; 1169 };
1138 } 1170 }
1139}; 1171};
1140 1172
1141register "<global>", __PACKAGE__;
1142
1143unshift @INC, $LIBDIR; 1173unshift @INC, $LIBDIR;
1144 1174
1145$TICK_WATCHER = Event->timer ( 1175$TICK_WATCHER = Event->timer (
1146 prio => 1, 1176 prio => 1,
1177 async => 1,
1147 at => $NEXT_TICK || 1, 1178 at => $NEXT_TICK || 1,
1179 data => WF_AUTOCANCEL,
1148 cb => sub { 1180 cb => sub {
1149 cf::server_tick; # one server iteration 1181 cf::server_tick; # one server iteration
1150 1182
1151 my $NOW = Event::time; 1183 my $NOW = Event::time;
1152 $NEXT_TICK += $TICK; 1184 $NEXT_TICK += $TICK;
1153 1185
1154 # if we are delayed by four ticks, skip them all 1186 # if we are delayed by four ticks or more, skip them all
1155 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1187 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1156 1188
1157 $TICK_WATCHER->at ($NEXT_TICK); 1189 $TICK_WATCHER->at ($NEXT_TICK);
1158 $TICK_WATCHER->start; 1190 $TICK_WATCHER->start;
1159 }, 1191 },
1160); 1192);
1161 1193
1194IO::AIO::max_poll_time $TICK * 0.2;
1195
1196Event->io (fd => IO::AIO::poll_fileno,
1197 poll => 'r',
1198 prio => 5,
1199 data => WF_AUTOCANCEL,
1200 cb => \&IO::AIO::poll_cb);
1201
11621 12021
1163 1203

Diff Legend

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