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.76 by root, Mon Oct 2 15:28:36 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 ();
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
32our $uptime; 38our $UPTIME; $UPTIME ||= time;
33
34$uptime ||= time;
35 39
36############################################################################# 40#############################################################################
37 41
38=head2 GLOBAL VARIABLES 42=head2 GLOBAL VARIABLES
39 43
40=over 4 44=over 4
45
46=item $cf::UPTIME
47
48The timestamp of the server start (so not actually an uptime).
41 49
42=item $cf::LIBDIR 50=item $cf::LIBDIR
43 51
44The perl library directory, where extensions and cf-specific modules can 52The perl library directory, where extensions and cf-specific modules can
45be found. It will be added to C<@INC> automatically. 53be found. It will be added to C<@INC> automatically.
… …
70 78
71@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 79@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
72 80
73# 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
74# within the Safe compartment. 82# within the Safe compartment.
75for 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)) {
76 no strict 'refs'; 89 no strict 'refs';
77 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 90 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
78} 91}
79 92
80$Event::DIED = sub { 93$Event::DIED = sub {
… …
82}; 95};
83 96
84my %ext_pkg; 97my %ext_pkg;
85my @exts; 98my @exts;
86my @hook; 99my @hook;
87my %command;
88my %extcmd;
89 100
90=head2 UTILITY FUNCTIONS 101=head2 UTILITY FUNCTIONS
91 102
92=over 4 103=over 4
93 104
… …
522 unlink $filename; 533 unlink $filename;
523 unlink "$filename.pst"; 534 unlink "$filename.pst";
524 } 535 }
525} 536}
526 537
538sub object_freezer_as_string {
539 my ($rdata, $objs) = @_;
540
541 use Data::Dumper;
542
543 $$rdata . Dumper $objs
544}
545
527sub object_thawer_load { 546sub object_thawer_load {
528 my ($filename) = @_; 547 my ($filename) = @_;
529 548
530 local $/; 549 local $/;
531 550
… …
556 if exists $src->{_attachment}; 575 if exists $src->{_attachment};
557 }, 576 },
558; 577;
559 578
560############################################################################# 579#############################################################################
561# old plug-in events 580# command handling &c
562 581
563sub inject_event { 582=item cf::register_command $name => \&callback($ob,$args);
564 my $extension = shift;
565 my $event_code = shift;
566 583
567 my $cb = $hook[$event_code]{$extension} 584Register a callback for execution when the client sends the user command
568 or return; 585$name.
569 586
570 &$cb 587=cut
571}
572
573sub inject_global_event {
574 my $event = shift;
575
576 my $cb = $hook[$event]
577 or return;
578
579 List::Util::max map &$_, values %$cb
580}
581
582sub inject_command {
583 my ($name, $obj, $params) = @_;
584
585 for my $cmd (@{ $command{$name} }) {
586 $cmd->[1]->($obj, $params);
587 }
588
589 -1
590}
591 588
592sub register_command { 589sub register_command {
593 my ($name, $time, $cb) = @_; 590 my ($name, $cb) = @_;
594 591
595 my $caller = caller; 592 my $caller = caller;
596 #warn "registering command '$name/$time' to '$caller'"; 593 #warn "registering command '$name/$time' to '$caller'";
597 594
598 push @{ $command{$name} }, [$time, $cb, $caller]; 595 push @{ $COMMAND{$name} }, [$caller, $cb];
599 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
600} 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
601 606
602sub register_extcmd { 607sub register_extcmd {
603 my ($name, $cb) = @_; 608 my ($name, $cb) = @_;
604 609
605 my $caller = caller; 610 my $caller = caller;
606 #warn "registering extcmd '$name' to '$caller'"; 611 #warn "registering extcmd '$name' to '$caller'";
607 612
608 $extcmd{$name} = [$cb, $caller]; 613 $EXTCMD{$name} = [$cb, $caller];
609} 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;
610 647
611sub register { 648sub register {
612 my ($base, $pkg) = @_; 649 my ($base, $pkg) = @_;
613 650
614 #TODO 651 #TODO
… …
633 . "#line 1 \"$path\"\n{\n" 670 . "#line 1 \"$path\"\n{\n"
634 . (do { local $/; <$fh> }) 671 . (do { local $/; <$fh> })
635 . "\n};\n1"; 672 . "\n};\n1";
636 673
637 eval $source 674 eval $source
638 or die "$path: $@"; 675 or die $@ ? "$path: $@\n"
676 : "extension disabled.\n";
639 677
640 push @exts, $pkg; 678 push @exts, $pkg;
641 $ext_pkg{$base} = $pkg; 679 $ext_pkg{$base} = $pkg;
642 680
643# no strict 'refs'; 681# no strict 'refs';
… …
656# for my $idx (0 .. $#PLUGIN_EVENT) { 694# for my $idx (0 .. $#PLUGIN_EVENT) {
657# delete $hook[$idx]{$pkg}; 695# delete $hook[$idx]{$pkg};
658# } 696# }
659 697
660 # remove commands 698 # remove commands
661 for my $name (keys %command) { 699 for my $name (keys %COMMAND) {
662 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 700 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
663 701
664 if (@cb) { 702 if (@cb) {
665 $command{$name} = \@cb; 703 $COMMAND{$name} = \@cb;
666 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
667 } else { 704 } else {
668 delete $command{$name};
669 delete $COMMAND{"$name\000"}; 705 delete $COMMAND{$name};
670 } 706 }
671 } 707 }
672 708
673 # remove extcmds 709 # remove extcmds
674 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 710 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
675 delete $extcmd{$name}; 711 delete $EXTCMD{$name};
676 } 712 }
677 713
678 if (my $cb = $pkg->can ("unload")) { 714 if (my $cb = $pkg->can ("unload")) {
679 eval { 715 eval {
680 $cb->($pkg); 716 $cb->($pkg);
… …
684 720
685 Symbol::delete_package $pkg; 721 Symbol::delete_package $pkg;
686} 722}
687 723
688sub load_extensions { 724sub load_extensions {
689 my $LIBDIR = maps_directory "perl";
690
691 for my $ext (<$LIBDIR/*.ext>) { 725 for my $ext (<$LIBDIR/*.ext>) {
692 next unless -r $ext; 726 next unless -r $ext;
693 eval { 727 eval {
694 load_extension $ext; 728 load_extension $ext;
695 1 729 1
696 } or warn "$ext not loaded: $@"; 730 } or warn "$ext not loaded: $@";
697 } 731 }
698} 732}
699 733
700############################################################################# 734#############################################################################
701# extcmd framework, basically convert ext <msg>
702# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
703
704attach_to_players
705 on_extcmd => sub {
706 my ($pl, $buf) = @_;
707
708 my $msg = eval { from_json $buf };
709
710 if (ref $msg) {
711 if (my $cb = $extcmd{$msg->{msgtype}}) {
712 if (my %reply = $cb->[0]->($pl, $msg)) {
713 $pl->ext_reply ($msg->{msgid}, %reply);
714 }
715 }
716 } else {
717 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
718 }
719
720 cf::override;
721 },
722;
723
724#############################################################################
725# load/save/clean perl data associated with a map 735# load/save/clean perl data associated with a map
726 736
727*cf::mapsupport::on_clean = sub { 737*cf::mapsupport::on_clean = sub {
728 my ($map) = @_; 738 my ($map) = @_;
729 739
… …
774sub cf::player::exists($) { 784sub cf::player::exists($) {
775 cf::player::find $_[0] 785 cf::player::find $_[0]
776 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;
777} 787}
778 788
779=item $object->reply ($npc, $msg[, $flags]) 789=item $player_object->reply ($npc, $msg[, $flags])
780 790
781Sends 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>
782can 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
783dialogue with the given NPC character. 793dialogue with the given NPC character.
784 794
… …
811 $msg{msgid} = $id; 821 $msg{msgid} = $id;
812 822
813 $self->send ("ext " . to_json \%msg); 823 $self->send ("ext " . to_json \%msg);
814} 824}
815 825
816=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}
817 841
818=cut 842=cut
819 843
820############################################################################# 844#############################################################################
821 845
… …
823 847
824Functions that provide a safe environment to compile and execute 848Functions that provide a safe environment to compile and execute
825snippets of perl code without them endangering the safety of the server 849snippets of perl code without them endangering the safety of the server
826itself. Looping constructs, I/O operators and other built-in functionality 850itself. Looping constructs, I/O operators and other built-in functionality
827is not available in the safe scripting environment, and the number of 851is not available in the safe scripting environment, and the number of
828functions and methods that cna be called is greatly reduced. 852functions and methods that can be called is greatly reduced.
829 853
830=cut 854=cut
831 855
832our $safe = new Safe "safe"; 856our $safe = new Safe "safe";
833our $safe_hole = new Safe::Hole; 857our $safe_hole = new Safe::Hole;
… …
840 864
841=pod 865=pod
842 866
843The following fucntions and emthods are available within a safe environment: 867The following fucntions and emthods are available within a safe environment:
844 868
845 cf::object contr pay_amount pay_player 869 cf::object contr pay_amount pay_player map
846 cf::object::player player 870 cf::object::player player
847 cf::player peaceful 871 cf::player peaceful
872 cf::map trigger
848 873
849=cut 874=cut
850 875
851for ( 876for (
852 ["cf::object" => qw(contr pay_amount pay_player)], 877 ["cf::object" => qw(contr pay_amount pay_player map)],
853 ["cf::object::player" => qw(player)], 878 ["cf::object::player" => qw(player)],
854 ["cf::player" => qw(peaceful)], 879 ["cf::player" => qw(peaceful)],
880 ["cf::map" => qw(trigger)],
855) { 881) {
856 no strict 'refs'; 882 no strict 'refs';
857 my ($pkg, @funs) = @$_; 883 my ($pkg, @funs) = @$_;
858 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 884 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
859 for @funs; 885 for @funs;
… …
969 995
970Immediately write the database to disk I<if it is dirty>. 996Immediately write the database to disk I<if it is dirty>.
971 997
972=cut 998=cut
973 999
1000our $DB;
1001
974{ 1002{
975 my $db;
976 my $path = cf::localdir . "/database.pst"; 1003 my $path = cf::localdir . "/database.pst";
977 1004
978 sub db_load() { 1005 sub db_load() {
979 warn "loading database $path\n";#d# remove later 1006 warn "loading database $path\n";#d# remove later
980 $db = stat $path ? Storable::retrieve $path : { }; 1007 $DB = stat $path ? Storable::retrieve $path : { };
981 } 1008 }
982 1009
983 my $pid; 1010 my $pid;
984 1011
985 sub db_save() { 1012 sub db_save() {
986 warn "saving database $path\n";#d# remove later 1013 warn "saving database $path\n";#d# remove later
987 waitpid $pid, 0 if $pid; 1014 waitpid $pid, 0 if $pid;
988 if (0 == ($pid = fork)) { 1015 if (0 == ($pid = fork)) {
989 $db->{_meta}{version} = 1; 1016 $DB->{_meta}{version} = 1;
990 Storable::nstore $db, "$path~"; 1017 Storable::nstore $DB, "$path~";
991 rename "$path~", $path; 1018 rename "$path~", $path;
992 cf::_exit 0 if defined $pid; 1019 cf::_exit 0 if defined $pid;
993 } 1020 }
994 } 1021 }
995 1022
… …
998 sub db_sync() { 1025 sub db_sync() {
999 db_save if $dirty; 1026 db_save if $dirty;
1000 undef $dirty; 1027 undef $dirty;
1001 } 1028 }
1002 1029
1003 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 {
1004 db_sync; 1031 db_sync;
1005 }); 1032 });
1006 1033
1007 sub db_dirty() { 1034 sub db_dirty() {
1008 $dirty = 1; 1035 $dirty = 1;
1009 $idle->start; 1036 $idle->start;
1010 } 1037 }
1011 1038
1012 sub db_get($;$) { 1039 sub db_get($;$) {
1013 @_ >= 2 1040 @_ >= 2
1014 ? $db->{$_[0]}{$_[1]} 1041 ? $DB->{$_[0]}{$_[1]}
1015 : ($db->{$_[0]} ||= { }) 1042 : ($DB->{$_[0]} ||= { })
1016 } 1043 }
1017 1044
1018 sub db_put($$;$) { 1045 sub db_put($$;$) {
1019 if (@_ >= 3) { 1046 if (@_ >= 3) {
1020 $db->{$_[0]}{$_[1]} = $_[2]; 1047 $DB->{$_[0]}{$_[1]} = $_[2];
1021 } else { 1048 } else {
1022 $db->{$_[0]} = $_[1]; 1049 $DB->{$_[0]} = $_[1];
1023 } 1050 }
1024 db_dirty; 1051 db_dirty;
1025 } 1052 }
1026 1053
1027 attach_global 1054 attach_global
… …
1058 1085
1059 $msg->("reloading..."); 1086 $msg->("reloading...");
1060 1087
1061 eval { 1088 eval {
1062 # cancel all watchers 1089 # cancel all watchers
1063 $_->cancel for Event::all_watchers; 1090 for (Event::all_watchers) {
1091 $_->cancel if $_->data & WF_AUTOCANCEL;
1092 }
1064 1093
1065 # unload all extensions 1094 # unload all extensions
1066 for (@exts) { 1095 for (@exts) {
1067 $msg->("unloading <$_>"); 1096 $msg->("unloading <$_>");
1068 unload_extension $_; 1097 unload_extension $_;
… …
1128 warn $_[0]; 1157 warn $_[0];
1129 print "$_[0]\n"; 1158 print "$_[0]\n";
1130 }; 1159 };
1131} 1160}
1132 1161
1162register "<global>", __PACKAGE__;
1163
1133register_command "perl-reload", 0, sub { 1164register_command "perl-reload" => sub {
1134 my ($who, $arg) = @_; 1165 my ($who, $arg) = @_;
1135 1166
1136 if ($who->flag (FLAG_WIZ)) { 1167 if ($who->flag (FLAG_WIZ)) {
1137 _perl_reload { 1168 _perl_reload {
1138 warn $_[0]; 1169 warn $_[0];
1139 $who->message ($_[0]); 1170 $who->message ($_[0]);
1140 }; 1171 };
1141 } 1172 }
1142}; 1173};
1143 1174
1144register "<global>", __PACKAGE__;
1145
1146unshift @INC, $LIBDIR; 1175unshift @INC, $LIBDIR;
1147 1176
1148$TICK_WATCHER = Event->timer ( 1177$TICK_WATCHER = Event->timer (
1149 prio => 1, 1178 prio => 0,
1150 at => $NEXT_TICK || 1, 1179 at => $NEXT_TICK || 1,
1180 data => WF_AUTOCANCEL,
1151 cb => sub { 1181 cb => sub {
1152 cf::server_tick; # one server iteration 1182 cf::server_tick; # one server iteration
1153 1183
1154 my $NOW = Event::time; 1184 my $NOW = Event::time;
1155 $NEXT_TICK += $TICK; 1185 $NEXT_TICK += $TICK;
1156 1186
1157 # if we are delayed by four ticks, skip them all 1187 # if we are delayed by four ticks or more, skip them all
1158 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1188 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1159 1189
1160 $TICK_WATCHER->at ($NEXT_TICK); 1190 $TICK_WATCHER->at ($NEXT_TICK);
1161 $TICK_WATCHER->start; 1191 $TICK_WATCHER->start;
1162 }, 1192 },
1163); 1193);
1164 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
11651 12031
1166 1204

Diff Legend

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