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.70 by root, Sun Oct 1 10:55:37 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
… …
108 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 127 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
109 JSON::Syck::Dump $_[0] 128 JSON::Syck::Dump $_[0]
110} 129}
111 130
112=back 131=back
132
133=cut
113 134
114############################################################################# 135#############################################################################
115 136
116=head2 EVENTS AND OBJECT ATTACHMENTS 137=head2 EVENTS AND OBJECT ATTACHMENTS
117 138
… …
420This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be 441This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
421removed in future versions), and there is no public API to access override 442removed in future versions), and there is no public API to access override
422results (if you must, access C<@cf::invoke_results> directly). 443results (if you must, access C<@cf::invoke_results> directly).
423 444
424=back 445=back
446
447=cut
425 448
426############################################################################# 449#############################################################################
427 450
428=head2 METHODS VALID FOR ALL CORE OBJECTS 451=head2 METHODS VALID FOR ALL CORE OBJECTS
429 452
… …
510 unlink $filename; 533 unlink $filename;
511 unlink "$filename.pst"; 534 unlink "$filename.pst";
512 } 535 }
513} 536}
514 537
538sub object_freezer_as_string {
539 my ($rdata, $objs) = @_;
540
541 use Data::Dumper;
542
543 $$rdata . Dumper $objs
544}
545
515sub object_thawer_load { 546sub object_thawer_load {
516 my ($filename) = @_; 547 my ($filename) = @_;
517 548
518 local $/; 549 local $/;
519 550
… …
544 if exists $src->{_attachment}; 575 if exists $src->{_attachment};
545 }, 576 },
546; 577;
547 578
548############################################################################# 579#############################################################################
549# old plug-in events 580# command handling &c
550 581
551sub inject_event { 582=item cf::register_command $name => \&callback($ob,$args);
552 my $extension = shift;
553 my $event_code = shift;
554 583
555 my $cb = $hook[$event_code]{$extension} 584Register a callback for execution when the client sends the user command
556 or return; 585$name.
557 586
558 &$cb 587=cut
559}
560
561sub inject_global_event {
562 my $event = shift;
563
564 my $cb = $hook[$event]
565 or return;
566
567 List::Util::max map &$_, values %$cb
568}
569
570sub inject_command {
571 my ($name, $obj, $params) = @_;
572
573 for my $cmd (@{ $command{$name} }) {
574 $cmd->[1]->($obj, $params);
575 }
576
577 -1
578}
579 588
580sub register_command { 589sub register_command {
581 my ($name, $time, $cb) = @_; 590 my ($name, $cb) = @_;
582 591
583 my $caller = caller; 592 my $caller = caller;
584 #warn "registering command '$name/$time' to '$caller'"; 593 #warn "registering command '$name/$time' to '$caller'";
585 594
586 push @{ $command{$name} }, [$time, $cb, $caller]; 595 push @{ $COMMAND{$name} }, [$caller, $cb];
587 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
588} 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
589 606
590sub register_extcmd { 607sub register_extcmd {
591 my ($name, $cb) = @_; 608 my ($name, $cb) = @_;
592 609
593 my $caller = caller; 610 my $caller = caller;
594 #warn "registering extcmd '$name' to '$caller'"; 611 #warn "registering extcmd '$name' to '$caller'";
595 612
596 $extcmd{$name} = [$cb, $caller]; 613 $EXTCMD{$name} = [$cb, $caller];
597} 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;
598 647
599sub register { 648sub register {
600 my ($base, $pkg) = @_; 649 my ($base, $pkg) = @_;
601 650
602 #TODO 651 #TODO
… …
621 . "#line 1 \"$path\"\n{\n" 670 . "#line 1 \"$path\"\n{\n"
622 . (do { local $/; <$fh> }) 671 . (do { local $/; <$fh> })
623 . "\n};\n1"; 672 . "\n};\n1";
624 673
625 eval $source 674 eval $source
626 or die "$path: $@"; 675 or die $@ ? "$path: $@\n"
676 : "extension disabled.\n";
627 677
628 push @exts, $pkg; 678 push @exts, $pkg;
629 $ext_pkg{$base} = $pkg; 679 $ext_pkg{$base} = $pkg;
630 680
631# no strict 'refs'; 681# no strict 'refs';
… …
644# for my $idx (0 .. $#PLUGIN_EVENT) { 694# for my $idx (0 .. $#PLUGIN_EVENT) {
645# delete $hook[$idx]{$pkg}; 695# delete $hook[$idx]{$pkg};
646# } 696# }
647 697
648 # remove commands 698 # remove commands
649 for my $name (keys %command) { 699 for my $name (keys %COMMAND) {
650 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 700 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
651 701
652 if (@cb) { 702 if (@cb) {
653 $command{$name} = \@cb; 703 $COMMAND{$name} = \@cb;
654 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
655 } else { 704 } else {
656 delete $command{$name};
657 delete $COMMAND{"$name\000"}; 705 delete $COMMAND{$name};
658 } 706 }
659 } 707 }
660 708
661 # remove extcmds 709 # remove extcmds
662 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 710 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
663 delete $extcmd{$name}; 711 delete $EXTCMD{$name};
664 } 712 }
665 713
666 if (my $cb = $pkg->can ("unload")) { 714 if (my $cb = $pkg->can ("unload")) {
667 eval { 715 eval {
668 $cb->($pkg); 716 $cb->($pkg);
… …
672 720
673 Symbol::delete_package $pkg; 721 Symbol::delete_package $pkg;
674} 722}
675 723
676sub load_extensions { 724sub load_extensions {
677 my $LIBDIR = maps_directory "perl";
678
679 for my $ext (<$LIBDIR/*.ext>) { 725 for my $ext (<$LIBDIR/*.ext>) {
680 next unless -r $ext; 726 next unless -r $ext;
681 eval { 727 eval {
682 load_extension $ext; 728 load_extension $ext;
683 1 729 1
684 } or warn "$ext not loaded: $@"; 730 } or warn "$ext not loaded: $@";
685 } 731 }
686} 732}
687 733
688############################################################################# 734#############################################################################
689# extcmd framework, basically convert ext <msg>
690# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
691
692attach_to_players
693 on_extcmd => sub {
694 my ($pl, $buf) = @_;
695
696 my $msg = eval { from_json $buf };
697
698 if (ref $msg) {
699 if (my $cb = $extcmd{$msg->{msgtype}}) {
700 if (my %reply = $cb->[0]->($pl, $msg)) {
701 $pl->ext_reply ($msg->{msgid}, %reply);
702 }
703 }
704 } else {
705 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
706 }
707
708 cf::override;
709 },
710;
711
712#############################################################################
713# load/save/clean perl data associated with a map 735# load/save/clean perl data associated with a map
714 736
715*cf::mapsupport::on_clean = sub { 737*cf::mapsupport::on_clean = sub {
716 my ($map) = @_; 738 my ($map) = @_;
717 739
… …
762sub cf::player::exists($) { 784sub cf::player::exists($) {
763 cf::player::find $_[0] 785 cf::player::find $_[0]
764 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;
765} 787}
766 788
767=item $player->reply ($npc, $msg[, $flags]) 789=item $player_object->reply ($npc, $msg[, $flags])
768 790
769Sends 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>
770can 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
771dialogue with the given NPC character. 793dialogue with the given NPC character.
772 794
… …
799 $msg{msgid} = $id; 821 $msg{msgid} = $id;
800 822
801 $self->send ("ext " . to_json \%msg); 823 $self->send ("ext " . to_json \%msg);
802} 824}
803 825
804=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}
805 841
806=cut 842=cut
807 843
808############################################################################# 844#############################################################################
809 845
… …
811 847
812Functions that provide a safe environment to compile and execute 848Functions that provide a safe environment to compile and execute
813snippets of perl code without them endangering the safety of the server 849snippets of perl code without them endangering the safety of the server
814itself. Looping constructs, I/O operators and other built-in functionality 850itself. Looping constructs, I/O operators and other built-in functionality
815is not available in the safe scripting environment, and the number of 851is not available in the safe scripting environment, and the number of
816functions and methods that cna be called is greatly reduced. 852functions and methods that can be called is greatly reduced.
817 853
818=cut 854=cut
819 855
820our $safe = new Safe "safe"; 856our $safe = new Safe "safe";
821our $safe_hole = new Safe::Hole; 857our $safe_hole = new Safe::Hole;
… …
828 864
829=pod 865=pod
830 866
831The following fucntions and emthods are available within a safe environment: 867The following fucntions and emthods are available within a safe environment:
832 868
833 cf::object contr pay_amount pay_player 869 cf::object contr pay_amount pay_player map
834 cf::object::player player 870 cf::object::player player
835 cf::player peaceful 871 cf::player peaceful
872 cf::map trigger
836 873
837=cut 874=cut
838 875
839for ( 876for (
840 ["cf::object" => qw(contr pay_amount pay_player)], 877 ["cf::object" => qw(contr pay_amount pay_player map)],
841 ["cf::object::player" => qw(player)], 878 ["cf::object::player" => qw(player)],
842 ["cf::player" => qw(peaceful)], 879 ["cf::player" => qw(peaceful)],
880 ["cf::map" => qw(trigger)],
843) { 881) {
844 no strict 'refs'; 882 no strict 'refs';
845 my ($pkg, @funs) = @$_; 883 my ($pkg, @funs) = @$_;
846 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 884 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
847 for @funs; 885 for @funs;
… …
912 *{"safe::$fun"} = $safe_hole->wrap ($cb); 950 *{"safe::$fun"} = $safe_hole->wrap ($cb);
913} 951}
914 952
915=back 953=back
916 954
955=cut
956
917############################################################################# 957#############################################################################
918 958
919=head2 EXTENSION DATABASE SUPPORT 959=head2 EXTENSION DATABASE SUPPORT
920 960
921Crossfire maintains a very simple database for extension use. It can 961Crossfire maintains a very simple database for extension use. It can
… …
955 995
956Immediately write the database to disk I<if it is dirty>. 996Immediately write the database to disk I<if it is dirty>.
957 997
958=cut 998=cut
959 999
1000our $DB;
1001
960{ 1002{
961 my $db;
962 my $path = cf::localdir . "/database.pst"; 1003 my $path = cf::localdir . "/database.pst";
963 1004
964 sub db_load() { 1005 sub db_load() {
965 warn "loading database $path\n";#d# remove later 1006 warn "loading database $path\n";#d# remove later
966 $db = stat $path ? Storable::retrieve $path : { }; 1007 $DB = stat $path ? Storable::retrieve $path : { };
967 } 1008 }
968 1009
969 my $pid; 1010 my $pid;
970 1011
971 sub db_save() { 1012 sub db_save() {
972 warn "saving database $path\n";#d# remove later 1013 warn "saving database $path\n";#d# remove later
973 waitpid $pid, 0 if $pid; 1014 waitpid $pid, 0 if $pid;
974 if (0 == ($pid = fork)) { 1015 if (0 == ($pid = fork)) {
975 $db->{_meta}{version} = 1; 1016 $DB->{_meta}{version} = 1;
976 Storable::nstore $db, "$path~"; 1017 Storable::nstore $DB, "$path~";
977 rename "$path~", $path; 1018 rename "$path~", $path;
978 cf::_exit 0 if defined $pid; 1019 cf::_exit 0 if defined $pid;
979 } 1020 }
980 } 1021 }
981 1022
… …
984 sub db_sync() { 1025 sub db_sync() {
985 db_save if $dirty; 1026 db_save if $dirty;
986 undef $dirty; 1027 undef $dirty;
987 } 1028 }
988 1029
989 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 {
990 db_sync; 1031 db_sync;
991 }); 1032 });
992 1033
993 sub db_dirty() { 1034 sub db_dirty() {
994 $dirty = 1; 1035 $dirty = 1;
995 $idle->start; 1036 $idle->start;
996 } 1037 }
997 1038
998 sub db_get($;$) { 1039 sub db_get($;$) {
999 @_ >= 2 1040 @_ >= 2
1000 ? $db->{$_[0]}{$_[1]} 1041 ? $DB->{$_[0]}{$_[1]}
1001 : ($db->{$_[0]} ||= { }) 1042 : ($DB->{$_[0]} ||= { })
1002 } 1043 }
1003 1044
1004 sub db_put($$;$) { 1045 sub db_put($$;$) {
1005 if (@_ >= 3) { 1046 if (@_ >= 3) {
1006 $db->{$_[0]}{$_[1]} = $_[2]; 1047 $DB->{$_[0]}{$_[1]} = $_[2];
1007 } else { 1048 } else {
1008 $db->{$_[0]} = $_[1]; 1049 $DB->{$_[0]} = $_[1];
1009 } 1050 }
1010 db_dirty; 1051 db_dirty;
1011 } 1052 }
1012 1053
1013 attach_global 1054 attach_global
… …
1019} 1060}
1020 1061
1021############################################################################# 1062#############################################################################
1022# the server's main() 1063# the server's main()
1023 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
1024sub main { 1073sub main {
1074 cfg_load;
1025 db_load; 1075 db_load;
1026 load_extensions; 1076 load_extensions;
1027 Event::loop; 1077 Event::loop;
1028} 1078}
1029 1079
… …
1035 1085
1036 $msg->("reloading..."); 1086 $msg->("reloading...");
1037 1087
1038 eval { 1088 eval {
1039 # cancel all watchers 1089 # cancel all watchers
1040 $_->cancel for Event::all_watchers; 1090 for (Event::all_watchers) {
1091 $_->cancel if $_->data & WF_AUTOCANCEL;
1092 }
1041 1093
1042 # unload all extensions 1094 # unload all extensions
1043 for (@exts) { 1095 for (@exts) {
1044 $msg->("unloading <$_>"); 1096 $msg->("unloading <$_>");
1045 unload_extension $_; 1097 unload_extension $_;
… …
1081 1133
1082 # reload cf.pm 1134 # reload cf.pm
1083 $msg->("reloading cf.pm"); 1135 $msg->("reloading cf.pm");
1084 require cf; 1136 require cf;
1085 1137
1086 # load database again 1138 # load config and database again
1139 cf::cfg_load;
1087 cf::db_load; 1140 cf::db_load;
1088 1141
1089 # load extensions 1142 # load extensions
1090 $msg->("load extensions"); 1143 $msg->("load extensions");
1091 cf::load_extensions; 1144 cf::load_extensions;
… …
1104 warn $_[0]; 1157 warn $_[0];
1105 print "$_[0]\n"; 1158 print "$_[0]\n";
1106 }; 1159 };
1107} 1160}
1108 1161
1162register "<global>", __PACKAGE__;
1163
1109register_command "perl-reload", 0, sub { 1164register_command "perl-reload" => sub {
1110 my ($who, $arg) = @_; 1165 my ($who, $arg) = @_;
1111 1166
1112 if ($who->flag (FLAG_WIZ)) { 1167 if ($who->flag (FLAG_WIZ)) {
1113 _perl_reload { 1168 _perl_reload {
1114 warn $_[0]; 1169 warn $_[0];
1115 $who->message ($_[0]); 1170 $who->message ($_[0]);
1116 }; 1171 };
1117 } 1172 }
1118}; 1173};
1119 1174
1120register "<global>", __PACKAGE__;
1121
1122unshift @INC, $LIBDIR; 1175unshift @INC, $LIBDIR;
1123 1176
1124$TICK_WATCHER = Event->timer ( 1177$TICK_WATCHER = Event->timer (
1125 prio => 1, 1178 prio => 0,
1126 at => $NEXT_TICK || 1, 1179 at => $NEXT_TICK || 1,
1180 data => WF_AUTOCANCEL,
1127 cb => sub { 1181 cb => sub {
1128 cf::server_tick; # one server iteration 1182 cf::server_tick; # one server iteration
1129 1183
1130 my $NOW = Event::time; 1184 my $NOW = Event::time;
1131 $NEXT_TICK += $TICK; 1185 $NEXT_TICK += $TICK;
1132 1186
1133 # if we are delayed by four ticks, skip them all 1187 # if we are delayed by four ticks or more, skip them all
1134 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1188 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1135 1189
1136 $TICK_WATCHER->at ($NEXT_TICK); 1190 $TICK_WATCHER->at ($NEXT_TICK);
1137 $TICK_WATCHER->start; 1191 $TICK_WATCHER->start;
1138 }, 1192 },
1139); 1193);
1140 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
11411 12031
1142 1204

Diff Legend

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