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.71 by root, Sun Oct 1 10:59:30 2006 UTC vs.
Revision 1.91 by elmex, Sun Dec 17 22:03:44 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
21sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
22
23our %COMMAND = ();
24our %COMMAND_TIME = ();
25our %EXTCMD = ();
26
16_init_vars; 27_init_vars;
17 28
18our %COMMAND = ();
19our @EVENT; 29our @EVENT;
20our $LIBDIR = maps_directory "perl"; 30our $LIBDIR = datadir . "/ext";
21 31
22our $TICK = MAX_TIME * 1e-6; 32our $TICK = MAX_TIME * 1e-6;
23our $TICK_WATCHER; 33our $TICK_WATCHER;
24our $NEXT_TICK; 34our $NEXT_TICK;
25 35
26our %CFG; 36our %CFG;
27 37
38our $UPTIME; $UPTIME ||= time;
39
28############################################################################# 40#############################################################################
29 41
30=head2 GLOBAL VARIABLES 42=head2 GLOBAL VARIABLES
31 43
32=over 4 44=over 4
45
46=item $cf::UPTIME
47
48The timestamp of the server start (so not actually an uptime).
33 49
34=item $cf::LIBDIR 50=item $cf::LIBDIR
35 51
36The perl library directory, where extensions and cf-specific modules can 52The perl library directory, where extensions and cf-specific modules can
37be found. It will be added to C<@INC> automatically. 53be found. It will be added to C<@INC> automatically.
… …
62 78
63@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 79@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
64 80
65# 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
66# within the Safe compartment. 82# within the Safe compartment.
67for 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)) {
68 no strict 'refs'; 89 no strict 'refs';
69 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 90 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
70} 91}
71 92
72$Event::DIED = sub { 93$Event::DIED = sub {
… …
74}; 95};
75 96
76my %ext_pkg; 97my %ext_pkg;
77my @exts; 98my @exts;
78my @hook; 99my @hook;
79my %command;
80my %extcmd;
81 100
82=head2 UTILITY FUNCTIONS 101=head2 UTILITY FUNCTIONS
83 102
84=over 4 103=over 4
85 104
… …
514 unlink $filename; 533 unlink $filename;
515 unlink "$filename.pst"; 534 unlink "$filename.pst";
516 } 535 }
517} 536}
518 537
538sub object_freezer_as_string {
539 my ($rdata, $objs) = @_;
540
541 use Data::Dumper;
542
543 $$rdata . Dumper $objs
544}
545
519sub object_thawer_load { 546sub object_thawer_load {
520 my ($filename) = @_; 547 my ($filename) = @_;
521 548
522 local $/; 549 local $/;
523 550
… …
548 if exists $src->{_attachment}; 575 if exists $src->{_attachment};
549 }, 576 },
550; 577;
551 578
552############################################################################# 579#############################################################################
553# old plug-in events 580# command handling &c
554 581
555sub inject_event { 582=item cf::register_command $name => \&callback($ob,$args);
556 my $extension = shift;
557 my $event_code = shift;
558 583
559 my $cb = $hook[$event_code]{$extension} 584Register a callback for execution when the client sends the user command
560 or return; 585$name.
561 586
562 &$cb 587=cut
563}
564
565sub inject_global_event {
566 my $event = shift;
567
568 my $cb = $hook[$event]
569 or return;
570
571 List::Util::max map &$_, values %$cb
572}
573
574sub inject_command {
575 my ($name, $obj, $params) = @_;
576
577 for my $cmd (@{ $command{$name} }) {
578 $cmd->[1]->($obj, $params);
579 }
580
581 -1
582}
583 588
584sub register_command { 589sub register_command {
585 my ($name, $time, $cb) = @_; 590 my ($name, $cb) = @_;
586 591
587 my $caller = caller; 592 my $caller = caller;
588 #warn "registering command '$name/$time' to '$caller'"; 593 #warn "registering command '$name/$time' to '$caller'";
589 594
590 push @{ $command{$name} }, [$time, $cb, $caller]; 595 push @{ $COMMAND{$name} }, [$caller, $cb];
591 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
592} 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
593 606
594sub register_extcmd { 607sub register_extcmd {
595 my ($name, $cb) = @_; 608 my ($name, $cb) = @_;
596 609
597 my $caller = caller; 610 my $caller = caller;
598 #warn "registering extcmd '$name' to '$caller'"; 611 #warn "registering extcmd '$name' to '$caller'";
599 612
600 $extcmd{$name} = [$cb, $caller]; 613 $EXTCMD{$name} = [$cb, $caller];
601} 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;
602 647
603sub register { 648sub register {
604 my ($base, $pkg) = @_; 649 my ($base, $pkg) = @_;
605 650
606 #TODO 651 #TODO
… …
625 . "#line 1 \"$path\"\n{\n" 670 . "#line 1 \"$path\"\n{\n"
626 . (do { local $/; <$fh> }) 671 . (do { local $/; <$fh> })
627 . "\n};\n1"; 672 . "\n};\n1";
628 673
629 eval $source 674 eval $source
630 or die "$path: $@"; 675 or die $@ ? "$path: $@\n"
676 : "extension disabled.\n";
631 677
632 push @exts, $pkg; 678 push @exts, $pkg;
633 $ext_pkg{$base} = $pkg; 679 $ext_pkg{$base} = $pkg;
634 680
635# no strict 'refs'; 681# no strict 'refs';
… …
648# for my $idx (0 .. $#PLUGIN_EVENT) { 694# for my $idx (0 .. $#PLUGIN_EVENT) {
649# delete $hook[$idx]{$pkg}; 695# delete $hook[$idx]{$pkg};
650# } 696# }
651 697
652 # remove commands 698 # remove commands
653 for my $name (keys %command) { 699 for my $name (keys %COMMAND) {
654 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 700 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
655 701
656 if (@cb) { 702 if (@cb) {
657 $command{$name} = \@cb; 703 $COMMAND{$name} = \@cb;
658 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
659 } else { 704 } else {
660 delete $command{$name};
661 delete $COMMAND{"$name\000"}; 705 delete $COMMAND{$name};
662 } 706 }
663 } 707 }
664 708
665 # remove extcmds 709 # remove extcmds
666 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 710 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
667 delete $extcmd{$name}; 711 delete $EXTCMD{$name};
668 } 712 }
669 713
670 if (my $cb = $pkg->can ("unload")) { 714 if (my $cb = $pkg->can ("unload")) {
671 eval { 715 eval {
672 $cb->($pkg); 716 $cb->($pkg);
… …
676 720
677 Symbol::delete_package $pkg; 721 Symbol::delete_package $pkg;
678} 722}
679 723
680sub load_extensions { 724sub load_extensions {
681 my $LIBDIR = maps_directory "perl";
682
683 for my $ext (<$LIBDIR/*.ext>) { 725 for my $ext (<$LIBDIR/*.ext>) {
684 next unless -r $ext; 726 next unless -r $ext;
685 eval { 727 eval {
686 load_extension $ext; 728 load_extension $ext;
687 1 729 1
688 } or warn "$ext not loaded: $@"; 730 } or warn "$ext not loaded: $@";
689 } 731 }
690} 732}
691 733
692############################################################################# 734#############################################################################
693# extcmd framework, basically convert ext <msg>
694# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
695
696attach_to_players
697 on_extcmd => sub {
698 my ($pl, $buf) = @_;
699
700 my $msg = eval { from_json $buf };
701
702 if (ref $msg) {
703 if (my $cb = $extcmd{$msg->{msgtype}}) {
704 if (my %reply = $cb->[0]->($pl, $msg)) {
705 $pl->ext_reply ($msg->{msgid}, %reply);
706 }
707 }
708 } else {
709 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
710 }
711
712 cf::override;
713 },
714;
715
716#############################################################################
717# load/save/clean perl data associated with a map 735# load/save/clean perl data associated with a map
718 736
719*cf::mapsupport::on_clean = sub { 737*cf::mapsupport::on_clean = sub {
720 my ($map) = @_; 738 my ($map) = @_;
721 739
… …
766sub cf::player::exists($) { 784sub cf::player::exists($) {
767 cf::player::find $_[0] 785 cf::player::find $_[0]
768 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;
769} 787}
770 788
771=item $player->reply ($npc, $msg[, $flags]) 789=item $player_object->reply ($npc, $msg[, $flags])
772 790
773Sends 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>
774can 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
775dialogue with the given NPC character. 793dialogue with the given NPC character.
776 794
… …
803 $msg{msgid} = $id; 821 $msg{msgid} = $id;
804 822
805 $self->send ("ext " . to_json \%msg); 823 $self->send ("ext " . to_json \%msg);
806} 824}
807 825
808=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}
809 841
810=cut 842=cut
811 843
812############################################################################# 844#############################################################################
813 845
… …
815 847
816Functions that provide a safe environment to compile and execute 848Functions that provide a safe environment to compile and execute
817snippets of perl code without them endangering the safety of the server 849snippets of perl code without them endangering the safety of the server
818itself. Looping constructs, I/O operators and other built-in functionality 850itself. Looping constructs, I/O operators and other built-in functionality
819is not available in the safe scripting environment, and the number of 851is not available in the safe scripting environment, and the number of
820functions and methods that cna be called is greatly reduced. 852functions and methods that can be called is greatly reduced.
821 853
822=cut 854=cut
823 855
824our $safe = new Safe "safe"; 856our $safe = new Safe "safe";
825our $safe_hole = new Safe::Hole; 857our $safe_hole = new Safe::Hole;
… …
832 864
833=pod 865=pod
834 866
835The following fucntions and emthods are available within a safe environment: 867The following fucntions and emthods are available within a safe environment:
836 868
837 cf::object contr pay_amount pay_player 869 cf::object contr pay_amount pay_player map
838 cf::object::player player 870 cf::object::player player
839 cf::player peaceful 871 cf::player peaceful
872 cf::map trigger
840 873
841=cut 874=cut
842 875
843for ( 876for (
844 ["cf::object" => qw(contr pay_amount pay_player)], 877 ["cf::object" => qw(contr pay_amount pay_player map)],
845 ["cf::object::player" => qw(player)], 878 ["cf::object::player" => qw(player)],
846 ["cf::player" => qw(peaceful)], 879 ["cf::player" => qw(peaceful)],
880 ["cf::map" => qw(trigger)],
847) { 881) {
848 no strict 'refs'; 882 no strict 'refs';
849 my ($pkg, @funs) = @$_; 883 my ($pkg, @funs) = @$_;
850 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 884 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
851 for @funs; 885 for @funs;
… …
961 995
962Immediately write the database to disk I<if it is dirty>. 996Immediately write the database to disk I<if it is dirty>.
963 997
964=cut 998=cut
965 999
1000our $DB;
1001
966{ 1002{
967 my $db;
968 my $path = cf::localdir . "/database.pst"; 1003 my $path = cf::localdir . "/database.pst";
969 1004
970 sub db_load() { 1005 sub db_load() {
971 warn "loading database $path\n";#d# remove later 1006 warn "loading database $path\n";#d# remove later
972 $db = stat $path ? Storable::retrieve $path : { }; 1007 $DB = stat $path ? Storable::retrieve $path : { };
973 } 1008 }
974 1009
975 my $pid; 1010 my $pid;
976 1011
977 sub db_save() { 1012 sub db_save() {
978 warn "saving database $path\n";#d# remove later 1013 warn "saving database $path\n";#d# remove later
979 waitpid $pid, 0 if $pid; 1014 waitpid $pid, 0 if $pid;
980 if (0 == ($pid = fork)) { 1015 if (0 == ($pid = fork)) {
981 $db->{_meta}{version} = 1; 1016 $DB->{_meta}{version} = 1;
982 Storable::nstore $db, "$path~"; 1017 Storable::nstore $DB, "$path~";
983 rename "$path~", $path; 1018 rename "$path~", $path;
984 cf::_exit 0 if defined $pid; 1019 cf::_exit 0 if defined $pid;
985 } 1020 }
986 } 1021 }
987 1022
… …
990 sub db_sync() { 1025 sub db_sync() {
991 db_save if $dirty; 1026 db_save if $dirty;
992 undef $dirty; 1027 undef $dirty;
993 } 1028 }
994 1029
995 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub { 1030 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
996 db_sync; 1031 db_sync;
997 }); 1032 });
998 1033
999 sub db_dirty() { 1034 sub db_dirty() {
1000 $dirty = 1; 1035 $dirty = 1;
1001 $idle->start; 1036 $idle->start;
1002 } 1037 }
1003 1038
1004 sub db_get($;$) { 1039 sub db_get($;$) {
1005 @_ >= 2 1040 @_ >= 2
1006 ? $db->{$_[0]}{$_[1]} 1041 ? $DB->{$_[0]}{$_[1]}
1007 : ($db->{$_[0]} ||= { }) 1042 : ($DB->{$_[0]} ||= { })
1008 } 1043 }
1009 1044
1010 sub db_put($$;$) { 1045 sub db_put($$;$) {
1011 if (@_ >= 3) { 1046 if (@_ >= 3) {
1012 $db->{$_[0]}{$_[1]} = $_[2]; 1047 $DB->{$_[0]}{$_[1]} = $_[2];
1013 } else { 1048 } else {
1014 $db->{$_[0]} = $_[1]; 1049 $DB->{$_[0]} = $_[1];
1015 } 1050 }
1016 db_dirty; 1051 db_dirty;
1017 } 1052 }
1018 1053
1019 attach_global 1054 attach_global
… …
1025} 1060}
1026 1061
1027############################################################################# 1062#############################################################################
1028# the server's main() 1063# the server's main()
1029 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
1030sub main { 1073sub main {
1074 cfg_load;
1031 db_load; 1075 db_load;
1032 load_extensions; 1076 load_extensions;
1033 Event::loop; 1077 Event::loop;
1034} 1078}
1035 1079
… …
1041 1085
1042 $msg->("reloading..."); 1086 $msg->("reloading...");
1043 1087
1044 eval { 1088 eval {
1045 # cancel all watchers 1089 # cancel all watchers
1046 $_->cancel for Event::all_watchers; 1090 for (Event::all_watchers) {
1091 $_->cancel if $_->data & WF_AUTOCANCEL;
1092 }
1047 1093
1048 # unload all extensions 1094 # unload all extensions
1049 for (@exts) { 1095 for (@exts) {
1050 $msg->("unloading <$_>"); 1096 $msg->("unloading <$_>");
1051 unload_extension $_; 1097 unload_extension $_;
… …
1087 1133
1088 # reload cf.pm 1134 # reload cf.pm
1089 $msg->("reloading cf.pm"); 1135 $msg->("reloading cf.pm");
1090 require cf; 1136 require cf;
1091 1137
1092 # load database again 1138 # load config and database again
1139 cf::cfg_load;
1093 cf::db_load; 1140 cf::db_load;
1094 1141
1095 # load extensions 1142 # load extensions
1096 $msg->("load extensions"); 1143 $msg->("load extensions");
1097 cf::load_extensions; 1144 cf::load_extensions;
… …
1110 warn $_[0]; 1157 warn $_[0];
1111 print "$_[0]\n"; 1158 print "$_[0]\n";
1112 }; 1159 };
1113} 1160}
1114 1161
1162register "<global>", __PACKAGE__;
1163
1115register_command "perl-reload", 0, sub { 1164register_command "perl-reload" => sub {
1116 my ($who, $arg) = @_; 1165 my ($who, $arg) = @_;
1117 1166
1118 if ($who->flag (FLAG_WIZ)) { 1167 if ($who->flag (FLAG_WIZ)) {
1119 _perl_reload { 1168 _perl_reload {
1120 warn $_[0]; 1169 warn $_[0];
1121 $who->message ($_[0]); 1170 $who->message ($_[0]);
1122 }; 1171 };
1123 } 1172 }
1124}; 1173};
1125 1174
1126register "<global>", __PACKAGE__;
1127
1128unshift @INC, $LIBDIR; 1175unshift @INC, $LIBDIR;
1129 1176
1130$TICK_WATCHER = Event->timer ( 1177$TICK_WATCHER = Event->timer (
1131 prio => 1, 1178 prio => 0,
1132 at => $NEXT_TICK || 1, 1179 at => $NEXT_TICK || 1,
1180 data => WF_AUTOCANCEL,
1133 cb => sub { 1181 cb => sub {
1134 cf::server_tick; # one server iteration 1182 cf::server_tick; # one server iteration
1135 1183
1136 my $NOW = Event::time; 1184 my $NOW = Event::time;
1137 $NEXT_TICK += $TICK; 1185 $NEXT_TICK += $TICK;
1138 1186
1139 # if we are delayed by four ticks, skip them all 1187 # if we are delayed by four ticks or more, skip them all
1140 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1188 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1141 1189
1142 $TICK_WATCHER->at ($NEXT_TICK); 1190 $TICK_WATCHER->at ($NEXT_TICK);
1143 $TICK_WATCHER->start; 1191 $TICK_WATCHER->start;
1144 }, 1192 },
1145); 1193);
1146 1194
1195IO::AIO::max_poll_time $TICK * 0.2;
1196
1197Event->io (fd => IO::AIO::poll_fileno,
1198 poll => 'r',
1199 prio => 5,
1200 data => WF_AUTOCANCEL,
1201 cb => \&IO::AIO::poll_cb);
1202
11471 12031
1148 1204

Diff Legend

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