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.74 by root, Sun Oct 1 15:59:29 2006 UTC vs.
Revision 1.90 by root, Sat Dec 16 04:22:13 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
… …
1054 1083
1055 $msg->("reloading..."); 1084 $msg->("reloading...");
1056 1085
1057 eval { 1086 eval {
1058 # cancel all watchers 1087 # cancel all watchers
1059 $_->cancel for Event::all_watchers; 1088 for (Event::all_watchers) {
1089 $_->cancel if $_->data & WF_AUTOCANCEL;
1090 }
1060 1091
1061 # unload all extensions 1092 # unload all extensions
1062 for (@exts) { 1093 for (@exts) {
1063 $msg->("unloading <$_>"); 1094 $msg->("unloading <$_>");
1064 unload_extension $_; 1095 unload_extension $_;
… …
1124 warn $_[0]; 1155 warn $_[0];
1125 print "$_[0]\n"; 1156 print "$_[0]\n";
1126 }; 1157 };
1127} 1158}
1128 1159
1160register "<global>", __PACKAGE__;
1161
1129register_command "perl-reload", 0, sub { 1162register_command "perl-reload" => sub {
1130 my ($who, $arg) = @_; 1163 my ($who, $arg) = @_;
1131 1164
1132 if ($who->flag (FLAG_WIZ)) { 1165 if ($who->flag (FLAG_WIZ)) {
1133 _perl_reload { 1166 _perl_reload {
1134 warn $_[0]; 1167 warn $_[0];
1135 $who->message ($_[0]); 1168 $who->message ($_[0]);
1136 }; 1169 };
1137 } 1170 }
1138}; 1171};
1139 1172
1140register "<global>", __PACKAGE__;
1141
1142unshift @INC, $LIBDIR; 1173unshift @INC, $LIBDIR;
1143 1174
1144$TICK_WATCHER = Event->timer ( 1175$TICK_WATCHER = Event->timer (
1145 prio => 1, 1176 prio => 0,
1146 at => $NEXT_TICK || 1, 1177 at => $NEXT_TICK || 1,
1178 data => WF_AUTOCANCEL,
1147 cb => sub { 1179 cb => sub {
1148 cf::server_tick; # one server iteration 1180 cf::server_tick; # one server iteration
1149 1181
1150 my $NOW = Event::time; 1182 my $NOW = Event::time;
1151 $NEXT_TICK += $TICK; 1183 $NEXT_TICK += $TICK;
1152 1184
1153 # if we are delayed by four ticks, skip them all 1185 # if we are delayed by four ticks or more, skip them all
1154 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1186 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1155 1187
1156 $TICK_WATCHER->at ($NEXT_TICK); 1188 $TICK_WATCHER->at ($NEXT_TICK);
1157 $TICK_WATCHER->start; 1189 $TICK_WATCHER->start;
1158 }, 1190 },
1159); 1191);
1160 1192
1193IO::AIO::max_poll_time $TICK * 0.2;
1194
1195Event->io (fd => IO::AIO::poll_fileno,
1196 poll => 'r',
1197 prio => 5,
1198 data => WF_AUTOCANCEL,
1199 cb => \&IO::AIO::poll_cb);
1200
11611 12011
1162 1202

Diff Legend

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