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.88 by root, Fri Dec 15 19:29:18 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_socket 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;
… …
912 *{"safe::$fun"} = $safe_hole->wrap ($cb); 948 *{"safe::$fun"} = $safe_hole->wrap ($cb);
913} 949}
914 950
915=back 951=back
916 952
953=cut
954
917############################################################################# 955#############################################################################
918 956
919=head2 EXTENSION DATABASE SUPPORT 957=head2 EXTENSION DATABASE SUPPORT
920 958
921Crossfire maintains a very simple database for extension use. It can 959Crossfire maintains a very simple database for extension use. It can
… …
955 993
956Immediately write the database to disk I<if it is dirty>. 994Immediately write the database to disk I<if it is dirty>.
957 995
958=cut 996=cut
959 997
998our $DB;
999
960{ 1000{
961 my $db;
962 my $path = cf::localdir . "/database.pst"; 1001 my $path = cf::localdir . "/database.pst";
963 1002
964 sub db_load() { 1003 sub db_load() {
965 warn "loading database $path\n";#d# remove later 1004 warn "loading database $path\n";#d# remove later
966 $db = stat $path ? Storable::retrieve $path : { }; 1005 $DB = stat $path ? Storable::retrieve $path : { };
967 } 1006 }
968 1007
969 my $pid; 1008 my $pid;
970 1009
971 sub db_save() { 1010 sub db_save() {
972 warn "saving database $path\n";#d# remove later 1011 warn "saving database $path\n";#d# remove later
973 waitpid $pid, 0 if $pid; 1012 waitpid $pid, 0 if $pid;
974 if (0 == ($pid = fork)) { 1013 if (0 == ($pid = fork)) {
975 $db->{_meta}{version} = 1; 1014 $DB->{_meta}{version} = 1;
976 Storable::nstore $db, "$path~"; 1015 Storable::nstore $DB, "$path~";
977 rename "$path~", $path; 1016 rename "$path~", $path;
978 cf::_exit 0 if defined $pid; 1017 cf::_exit 0 if defined $pid;
979 } 1018 }
980 } 1019 }
981 1020
… …
984 sub db_sync() { 1023 sub db_sync() {
985 db_save if $dirty; 1024 db_save if $dirty;
986 undef $dirty; 1025 undef $dirty;
987 } 1026 }
988 1027
989 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 {
990 db_sync; 1029 db_sync;
991 }); 1030 });
992 1031
993 sub db_dirty() { 1032 sub db_dirty() {
994 $dirty = 1; 1033 $dirty = 1;
995 $idle->start; 1034 $idle->start;
996 } 1035 }
997 1036
998 sub db_get($;$) { 1037 sub db_get($;$) {
999 @_ >= 2 1038 @_ >= 2
1000 ? $db->{$_[0]}{$_[1]} 1039 ? $DB->{$_[0]}{$_[1]}
1001 : ($db->{$_[0]} ||= { }) 1040 : ($DB->{$_[0]} ||= { })
1002 } 1041 }
1003 1042
1004 sub db_put($$;$) { 1043 sub db_put($$;$) {
1005 if (@_ >= 3) { 1044 if (@_ >= 3) {
1006 $db->{$_[0]}{$_[1]} = $_[2]; 1045 $DB->{$_[0]}{$_[1]} = $_[2];
1007 } else { 1046 } else {
1008 $db->{$_[0]} = $_[1]; 1047 $DB->{$_[0]} = $_[1];
1009 } 1048 }
1010 db_dirty; 1049 db_dirty;
1011 } 1050 }
1012 1051
1013 attach_global 1052 attach_global
… …
1019} 1058}
1020 1059
1021############################################################################# 1060#############################################################################
1022# the server's main() 1061# the server's main()
1023 1062
1063sub cfg_load {
1064 open my $fh, "<:utf8", cf::confdir . "/config"
1065 or return;
1066
1067 local $/;
1068 *CFG = YAML::Syck::Load <$fh>;
1069}
1070
1024sub main { 1071sub main {
1072 cfg_load;
1025 db_load; 1073 db_load;
1026 load_extensions; 1074 load_extensions;
1027 Event::loop; 1075 Event::loop;
1028} 1076}
1029 1077
… …
1035 1083
1036 $msg->("reloading..."); 1084 $msg->("reloading...");
1037 1085
1038 eval { 1086 eval {
1039 # cancel all watchers 1087 # cancel all watchers
1040 $_->cancel for Event::all_watchers; 1088 for (Event::all_watchers) {
1089 $_->cancel if $_->data & WF_AUTOCANCEL;
1090 }
1041 1091
1042 # unload all extensions 1092 # unload all extensions
1043 for (@exts) { 1093 for (@exts) {
1044 $msg->("unloading <$_>"); 1094 $msg->("unloading <$_>");
1045 unload_extension $_; 1095 unload_extension $_;
… …
1081 1131
1082 # reload cf.pm 1132 # reload cf.pm
1083 $msg->("reloading cf.pm"); 1133 $msg->("reloading cf.pm");
1084 require cf; 1134 require cf;
1085 1135
1086 # load database again 1136 # load config and database again
1137 cf::cfg_load;
1087 cf::db_load; 1138 cf::db_load;
1088 1139
1089 # load extensions 1140 # load extensions
1090 $msg->("load extensions"); 1141 $msg->("load extensions");
1091 cf::load_extensions; 1142 cf::load_extensions;
… …
1104 warn $_[0]; 1155 warn $_[0];
1105 print "$_[0]\n"; 1156 print "$_[0]\n";
1106 }; 1157 };
1107} 1158}
1108 1159
1160register "<global>", __PACKAGE__;
1161
1109register_command "perl-reload", 0, sub { 1162register_command "perl-reload" => sub {
1110 my ($who, $arg) = @_; 1163 my ($who, $arg) = @_;
1111 1164
1112 if ($who->flag (FLAG_WIZ)) { 1165 if ($who->flag (FLAG_WIZ)) {
1113 _perl_reload { 1166 _perl_reload {
1114 warn $_[0]; 1167 warn $_[0];
1115 $who->message ($_[0]); 1168 $who->message ($_[0]);
1116 }; 1169 };
1117 } 1170 }
1118}; 1171};
1119 1172
1120register "<global>", __PACKAGE__;
1121
1122unshift @INC, $LIBDIR; 1173unshift @INC, $LIBDIR;
1123 1174
1124$TICK_WATCHER = Event->timer ( 1175$TICK_WATCHER = Event->timer (
1125 prio => 1, 1176 prio => 1,
1177 async => 1,
1126 at => $NEXT_TICK || 1, 1178 at => $NEXT_TICK || 1,
1179 data => WF_AUTOCANCEL,
1127 cb => sub { 1180 cb => sub {
1128 cf::server_tick; # one server iteration 1181 cf::server_tick; # one server iteration
1129 1182
1130 my $NOW = Event::time; 1183 my $NOW = Event::time;
1131 $NEXT_TICK += $TICK; 1184 $NEXT_TICK += $TICK;
1132 1185
1133 # if we are delayed by four ticks, skip them all 1186 # if we are delayed by four ticks or more, skip them all
1134 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1187 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1135 1188
1136 $TICK_WATCHER->at ($NEXT_TICK); 1189 $TICK_WATCHER->at ($NEXT_TICK);
1137 $TICK_WATCHER->start; 1190 $TICK_WATCHER->start;
1138 }, 1191 },
1139); 1192);
1140 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
11411 12021
1142 1203

Diff Legend

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