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.61 by root, Sun Sep 3 22:45:56 2006 UTC vs.
Revision 1.83 by root, Mon Dec 11 01:30:41 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
16_reload_1; 21_init_vars;
17 22
18our %COMMAND = (); 23our %COMMAND = ();
19our @EVENT; 24our @EVENT;
20our %PROP_TYPE;
21our %PROP_IDX;
22our $LIBDIR = maps_directory "perl"; 25our $LIBDIR = maps_directory "perl";
23 26
24our $TICK = MAX_TIME * 1e-6; 27our $TICK = MAX_TIME * 1e-6;
25our $TICK_WATCHER; 28our $TICK_WATCHER;
26our $NEXT_TICK; 29our $NEXT_TICK;
30
31our %CFG;
32
33our $uptime;#d#
34our $UPTIME;
35$UPTIME ||= $uptime;#d#
36$UPTIME ||= time;
37
38#############################################################################
39
40=head2 GLOBAL VARIABLES
41
42=over 4
43
44=item $cf::UPTIME
45
46The timestamp of the server start (so not actually an uptime).
47
48=item $cf::LIBDIR
49
50The perl library directory, where extensions and cf-specific modules can
51be found. It will be added to C<@INC> automatically.
52
53=item $cf::TICK
54
55The interval between server ticks, in seconds.
56
57=item %cf::CFG
58
59Configuration for the server, loaded from C</etc/crossfire/config>, or
60from wherever your confdir points to.
61
62=back
63
64=cut
27 65
28BEGIN { 66BEGIN {
29 *CORE::GLOBAL::warn = sub { 67 *CORE::GLOBAL::warn = sub {
30 my $msg = join "", @_; 68 my $msg = join "", @_;
31 $msg .= "\n" 69 $msg .= "\n"
… …
34 print STDERR "cfperl: $msg"; 72 print STDERR "cfperl: $msg";
35 LOG llevError, "cfperl: $msg"; 73 LOG llevError, "cfperl: $msg";
36 }; 74 };
37} 75}
38 76
39my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply!
40
41# generate property mutators
42sub prop_gen {
43 my ($prefix, $class) = @_;
44
45 no strict 'refs';
46
47 for my $prop (keys %PROP_TYPE) {
48 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
49 my $sub = lc $1;
50
51 my $type = $PROP_TYPE{$prop};
52 my $idx = $PROP_IDX {$prop};
53
54 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
55 $_[0]->get_property ($type, $idx)
56 };
57
58 *{"$class\::set_$sub"} = sub {
59 $_[0]->set_property ($type, $idx, $_[1]);
60 } unless $ignore_set{$prop};
61 }
62}
63
64# auto-generate most of the API
65
66prop_gen OBJECT_PROP => "cf::object";
67# CFAPI_OBJECT_ANIMATION?
68prop_gen PLAYER_PROP => "cf::object::player";
69
70prop_gen MAP_PROP => "cf::map";
71prop_gen ARCH_PROP => "cf::arch";
72
73@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 77@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
74 78
75# we bless all objects into (empty) derived classes to force a method lookup 79# we bless all objects into (empty) derived classes to force a method lookup
76# within the Safe compartment. 80# within the Safe compartment.
77for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) { 81for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) {
… …
87my @exts; 91my @exts;
88my @hook; 92my @hook;
89my %command; 93my %command;
90my %extcmd; 94my %extcmd;
91 95
92############################################################################# 96=head2 UTILITY FUNCTIONS
93# utility functions 97
98=over 4
99
100=cut
94 101
95use JSON::Syck (); # TODO# replace by JSON::PC once working 102use JSON::Syck (); # TODO# replace by JSON::PC once working
103
104=item $ref = cf::from_json $json
105
106Converts a JSON string into the corresponding perl data structure.
107
108=cut
96 109
97sub from_json($) { 110sub from_json($) {
98 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs 111 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
99 JSON::Syck::Load $_[0] 112 JSON::Syck::Load $_[0]
100} 113}
101 114
115=item $json = cf::to_json $ref
116
117Converts a perl data structure into its JSON representation.
118
119=cut
120
102sub to_json($) { 121sub to_json($) {
103 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 122 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
104 JSON::Syck::Dump $_[0] 123 JSON::Syck::Dump $_[0]
105} 124}
106 125
126=back
127
128=cut
129
107############################################################################# 130#############################################################################
108# "new" plug-in system
109 131
110=head3 EVENTS AND OBJECT ATTACHMENTS 132=head2 EVENTS AND OBJECT ATTACHMENTS
111 133
112=over 4 134=over 4
113 135
114=item $object->attach ($attachment, key => $value...) 136=item $object->attach ($attachment, key => $value...)
115 137
… …
389 for (@$callbacks) { 411 for (@$callbacks) {
390 eval { &{$_->[1]} }; 412 eval { &{$_->[1]} };
391 413
392 if ($@) { 414 if ($@) {
393 warn "$@"; 415 warn "$@";
394 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n"; 416 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
395 override; 417 override;
396 } 418 }
397 419
398 return 1 if $override; 420 return 1 if $override;
399 } 421 }
… …
415removed in future versions), and there is no public API to access override 437removed in future versions), and there is no public API to access override
416results (if you must, access C<@cf::invoke_results> directly). 438results (if you must, access C<@cf::invoke_results> directly).
417 439
418=back 440=back
419 441
420=head2 methods valid for all pointers 442=cut
443
444#############################################################################
445
446=head2 METHODS VALID FOR ALL CORE OBJECTS
421 447
422=over 4 448=over 4
423 449
424=item $object->valid 450=item $object->valid, $player->valid, $map->valid
425
426=item $player->valid
427
428=item $map->valid
429 451
430Just because you have a perl object does not mean that the corresponding 452Just because you have a perl object does not mean that the corresponding
431C-level object still exists. If you try to access an object that has no 453C-level object still exists. If you try to access an object that has no
432valid C counterpart anymore you get an exception at runtime. This method 454valid C counterpart anymore you get an exception at runtime. This method
433can be used to test for existence of the C object part without causing an 455can be used to test for existence of the C object part without causing an
… …
506 unlink $filename; 528 unlink $filename;
507 unlink "$filename.pst"; 529 unlink "$filename.pst";
508 } 530 }
509} 531}
510 532
533sub object_freezer_as_string {
534 my ($rdata, $objs) = @_;
535
536 use Data::Dumper;
537
538 $$rdata . Dumper $objs
539}
540
511sub object_thawer_load { 541sub object_thawer_load {
512 my ($filename) = @_; 542 my ($filename) = @_;
513 543
514 local $/; 544 local $/;
515 545
… …
617 . "#line 1 \"$path\"\n{\n" 647 . "#line 1 \"$path\"\n{\n"
618 . (do { local $/; <$fh> }) 648 . (do { local $/; <$fh> })
619 . "\n};\n1"; 649 . "\n};\n1";
620 650
621 eval $source 651 eval $source
622 or die "$path: $@"; 652 or die $@ ? "$path: $@\n"
653 : "extension disabled.\n";
623 654
624 push @exts, $pkg; 655 push @exts, $pkg;
625 $ext_pkg{$base} = $pkg; 656 $ext_pkg{$base} = $pkg;
626 657
627# no strict 'refs'; 658# no strict 'refs';
… …
678 load_extension $ext; 709 load_extension $ext;
679 1 710 1
680 } or warn "$ext not loaded: $@"; 711 } or warn "$ext not loaded: $@";
681 } 712 }
682} 713}
683
684sub _perl_reload(&) {
685 my ($msg) = @_;
686
687 $msg->("reloading...");
688
689 eval {
690 # 1. cancel all watchers
691 $_->cancel for Event::all_watchers;
692
693 # 2. unload all extensions
694 for (@exts) {
695 $msg->("unloading <$_>");
696 unload_extension $_;
697 }
698
699 # 3. unload all modules loaded from $LIBDIR
700 while (my ($k, $v) = each %INC) {
701 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
702
703 $msg->("removing <$k>");
704 delete $INC{$k};
705
706 $k =~ s/\.pm$//;
707 $k =~ s/\//::/g;
708
709 if (my $cb = $k->can ("unload_module")) {
710 $cb->();
711 }
712
713 Symbol::delete_package $k;
714 }
715
716 # 4. get rid of safe::, as good as possible
717 Symbol::delete_package "safe::$_"
718 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
719
720 # 5. remove register_script_function callbacks
721 # TODO
722
723 # 6. unload cf.pm "a bit"
724 delete $INC{"cf.pm"};
725
726 # don't, removes xs symbols, too,
727 # and global variables created in xs
728 #Symbol::delete_package __PACKAGE__;
729
730 # 7. reload cf.pm
731 $msg->("reloading cf.pm");
732 require cf;
733
734 $msg->("load extensions");
735 cf::load_extensions;
736 };
737 $msg->($@) if $@;
738
739 $msg->("reloaded");
740};
741
742sub perl_reload() {
743 _perl_reload {
744 warn $_[0];
745 print "$_[0]\n";
746 };
747}
748
749register_command "perl-reload", 0, sub {
750 my ($who, $arg) = @_;
751
752 if ($who->flag (FLAG_WIZ)) {
753 _perl_reload {
754 warn $_[0];
755 $who->message ($_[0]);
756 };
757 }
758};
759 714
760############################################################################# 715#############################################################################
761# extcmd framework, basically convert ext <msg> 716# extcmd framework, basically convert ext <msg>
762# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 717# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
763 718
… …
816 } 771 }
817 }, 772 },
818; 773;
819 774
820############################################################################# 775#############################################################################
821# core extensions - in perl 776
777=head2 CORE EXTENSIONS
778
779Functions and methods that extend core crossfire objects.
780
781=over 4
822 782
823=item cf::player::exists $login 783=item cf::player::exists $login
824 784
825Returns true when the given account exists. 785Returns true when the given account exists.
826 786
… …
829sub cf::player::exists($) { 789sub cf::player::exists($) {
830 cf::player::find $_[0] 790 cf::player::find $_[0]
831 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 791 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
832} 792}
833 793
834=item $player->reply ($npc, $msg[, $flags]) 794=item $player_object->reply ($npc, $msg[, $flags])
835 795
836Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 796Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
837can be C<undef>. Does the right thing when the player is currently in a 797can be C<undef>. Does the right thing when the player is currently in a
838dialogue with the given NPC character. 798dialogue with the given NPC character.
839 799
… …
866 $msg{msgid} = $id; 826 $msg{msgid} = $id;
867 827
868 $self->send ("ext " . to_json \%msg); 828 $self->send ("ext " . to_json \%msg);
869} 829}
870 830
831=item $player_object->may ("access")
832
833Returns wether the given player is authorized to access resource "access"
834(e.g. "command_wizcast").
835
836=cut
837
838sub cf::object::player::may {
839 my ($self, $access) = @_;
840
841 $self->flag (cf::FLAG_WIZ) ||
842 (ref $cf::CFG{"may_$access"}
843 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
844 : $cf::CFG{"may_$access"})
845}
846
847=cut
848
871############################################################################# 849#############################################################################
872# map scripting support 850
851=head2 SAFE SCRIPTING
852
853Functions that provide a safe environment to compile and execute
854snippets of perl code without them endangering the safety of the server
855itself. Looping constructs, I/O operators and other built-in functionality
856is not available in the safe scripting environment, and the number of
857functions and methods that can be called is greatly reduced.
858
859=cut
873 860
874our $safe = new Safe "safe"; 861our $safe = new Safe "safe";
875our $safe_hole = new Safe::Hole; 862our $safe_hole = new Safe::Hole;
876 863
877$SIG{FPE} = 'IGNORE'; 864$SIG{FPE} = 'IGNORE';
878 865
879$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 866$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
880 867
881# here we export the classes and methods available to script code 868# here we export the classes and methods available to script code
869
870=pod
871
872The following fucntions and emthods are available within a safe environment:
873
874 cf::object contr pay_amount pay_player
875 cf::object::player player
876 cf::player peaceful
877
878=cut
882 879
883for ( 880for (
884 ["cf::object" => qw(contr pay_amount pay_player)], 881 ["cf::object" => qw(contr pay_amount pay_player)],
885 ["cf::object::player" => qw(player)], 882 ["cf::object::player" => qw(player)],
886 ["cf::player" => qw(peaceful)], 883 ["cf::player" => qw(peaceful)],
… …
889 my ($pkg, @funs) = @$_; 886 my ($pkg, @funs) = @$_;
890 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 887 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
891 for @funs; 888 for @funs;
892} 889}
893 890
891=over 4
892
893=item @retval = safe_eval $code, [var => value, ...]
894
895Compiled and executes the given perl code snippet. additional var/value
896pairs result in temporary local (my) scalar variables of the given name
897that are available in the code snippet. Example:
898
899 my $five = safe_eval '$first + $second', first => 1, second => 4;
900
901=cut
902
894sub safe_eval($;@) { 903sub safe_eval($;@) {
895 my ($code, %vars) = @_; 904 my ($code, %vars) = @_;
896 905
897 my $qcode = $code; 906 my $qcode = $code;
898 $qcode =~ s/"/‟/g; # not allowed in #line filenames 907 $qcode =~ s/"/‟/g; # not allowed in #line filenames
… …
920 } 929 }
921 930
922 wantarray ? @res : $res[0] 931 wantarray ? @res : $res[0]
923} 932}
924 933
934=item cf::register_script_function $function => $cb
935
936Register a function that can be called from within map/npc scripts. The
937function should be reasonably secure and should be put into a package name
938like the extension.
939
940Example: register a function that gets called whenever a map script calls
941C<rent::overview>, as used by the C<rent> extension.
942
943 cf::register_script_function "rent::overview" => sub {
944 ...
945 };
946
947=cut
948
925sub register_script_function { 949sub register_script_function {
926 my ($fun, $cb) = @_; 950 my ($fun, $cb) = @_;
927 951
928 no strict 'refs'; 952 no strict 'refs';
929 *{"safe::$fun"} = $safe_hole->wrap ($cb); 953 *{"safe::$fun"} = $safe_hole->wrap ($cb);
930} 954}
931 955
956=back
957
958=cut
959
960#############################################################################
961
962=head2 EXTENSION DATABASE SUPPORT
963
964Crossfire maintains a very simple database for extension use. It can
965currently store anything that can be serialised using Storable, which
966excludes objects.
967
968The parameter C<$family> should best start with the name of the extension
969using it, it should be unique.
970
971=over 4
972
973=item $hashref = cf::db_get $family
974
975Return a hashref for use by the extension C<$family>, which can be
976modified. After modifications, you have to call C<cf::db_dirty> or
977C<cf::db_sync>.
978
979=item $value = cf::db_get $family => $key
980
981Returns a single value from the database
982
983=item cf::db_put $family => $hashref
984
985Stores the given family hashref into the database. Updates are delayed, if
986you want the data to be synced to disk immediately, use C<cf::db_sync>.
987
988=item cf::db_put $family => $key => $value
989
990Stores the given C<$value> in the family hash. Updates are delayed, if you
991want the data to be synced to disk immediately, use C<cf::db_sync>.
992
993=item cf::db_dirty
994
995Marks the database as dirty, to be updated at a later time.
996
997=item cf::db_sync
998
999Immediately write the database to disk I<if it is dirty>.
1000
1001=cut
1002
1003our $DB;
1004
1005{
1006 my $path = cf::localdir . "/database.pst";
1007
1008 sub db_load() {
1009 warn "loading database $path\n";#d# remove later
1010 $DB = stat $path ? Storable::retrieve $path : { };
1011 }
1012
1013 my $pid;
1014
1015 sub db_save() {
1016 warn "saving database $path\n";#d# remove later
1017 waitpid $pid, 0 if $pid;
1018 if (0 == ($pid = fork)) {
1019 $DB->{_meta}{version} = 1;
1020 Storable::nstore $DB, "$path~";
1021 rename "$path~", $path;
1022 cf::_exit 0 if defined $pid;
1023 }
1024 }
1025
1026 my $dirty;
1027
1028 sub db_sync() {
1029 db_save if $dirty;
1030 undef $dirty;
1031 }
1032
1033 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub {
1034 db_sync;
1035 });
1036
1037 sub db_dirty() {
1038 $dirty = 1;
1039 $idle->start;
1040 }
1041
1042 sub db_get($;$) {
1043 @_ >= 2
1044 ? $DB->{$_[0]}{$_[1]}
1045 : ($DB->{$_[0]} ||= { })
1046 }
1047
1048 sub db_put($$;$) {
1049 if (@_ >= 3) {
1050 $DB->{$_[0]}{$_[1]} = $_[2];
1051 } else {
1052 $DB->{$_[0]} = $_[1];
1053 }
1054 db_dirty;
1055 }
1056
1057 attach_global
1058 prio => 10000,
1059 on_cleanup => sub {
1060 db_sync;
1061 },
1062 ;
1063}
1064
932############################################################################# 1065#############################################################################
933# the server's main() 1066# the server's main()
934 1067
1068sub cfg_load {
1069 open my $fh, "<:utf8", cf::confdir . "/config"
1070 or return;
1071
1072 local $/;
1073 *CFG = YAML::Syck::Load <$fh>;
1074}
1075
935sub main { 1076sub main {
1077 cfg_load;
1078 db_load;
936 load_extensions; 1079 load_extensions;
937 Event::loop; 1080 Event::loop;
938} 1081}
939 1082
940############################################################################# 1083#############################################################################
941# initialisation 1084# initialisation
942 1085
1086sub _perl_reload(&) {
1087 my ($msg) = @_;
1088
1089 $msg->("reloading...");
1090
1091 eval {
1092 # cancel all watchers
1093 $_->cancel for Event::all_watchers;
1094
1095 # unload all extensions
1096 for (@exts) {
1097 $msg->("unloading <$_>");
1098 unload_extension $_;
1099 }
1100
1101 # unload all modules loaded from $LIBDIR
1102 while (my ($k, $v) = each %INC) {
1103 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1104
1105 $msg->("removing <$k>");
1106 delete $INC{$k};
1107
1108 $k =~ s/\.pm$//;
1109 $k =~ s/\//::/g;
1110
1111 if (my $cb = $k->can ("unload_module")) {
1112 $cb->();
1113 }
1114
1115 Symbol::delete_package $k;
1116 }
1117
1118 # sync database to disk
1119 cf::db_sync;
1120
1121 # get rid of safe::, as good as possible
1122 Symbol::delete_package "safe::$_"
1123 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
1124
1125 # remove register_script_function callbacks
1126 # TODO
1127
1128 # unload cf.pm "a bit"
1129 delete $INC{"cf.pm"};
1130
1131 # don't, removes xs symbols, too,
1132 # and global variables created in xs
1133 #Symbol::delete_package __PACKAGE__;
1134
1135 # reload cf.pm
1136 $msg->("reloading cf.pm");
1137 require cf;
1138
1139 # load config and database again
1140 cf::cfg_load;
1141 cf::db_load;
1142
1143 # load extensions
1144 $msg->("load extensions");
1145 cf::load_extensions;
1146
1147 # reattach attachments to objects
1148 $msg->("reattach");
1149 _global_reattach;
1150 };
1151 $msg->($@) if $@;
1152
1153 $msg->("reloaded");
1154};
1155
1156sub perl_reload() {
1157 _perl_reload {
1158 warn $_[0];
1159 print "$_[0]\n";
1160 };
1161}
1162
1163register_command "perl-reload", 0, sub {
1164 my ($who, $arg) = @_;
1165
1166 if ($who->flag (FLAG_WIZ)) {
1167 _perl_reload {
1168 warn $_[0];
1169 $who->message ($_[0]);
1170 };
1171 }
1172};
1173
943register "<global>", __PACKAGE__; 1174register "<global>", __PACKAGE__;
944 1175
945unshift @INC, $LIBDIR; 1176unshift @INC, $LIBDIR;
946 1177
947$TICK_WATCHER = Event->timer ( 1178$TICK_WATCHER = Event->timer (
948 prio => 1, 1179 prio => 1,
1180 async => 1,
949 at => $NEXT_TICK || 1, 1181 at => $NEXT_TICK || 1,
950 cb => sub { 1182 cb => sub {
951 cf::server_tick; # one server iteration 1183 cf::server_tick; # one server iteration
952 1184
953 my $NOW = Event::time; 1185 my $NOW = Event::time;
954 $NEXT_TICK += $TICK; 1186 $NEXT_TICK += $TICK;
955 1187
956 # if we are delayed by four ticks, skip them all 1188 # if we are delayed by four ticks or more, skip them all
957 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1189 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
958 1190
959 $TICK_WATCHER->at ($NEXT_TICK); 1191 $TICK_WATCHER->at ($NEXT_TICK);
960 $TICK_WATCHER->start; 1192 $TICK_WATCHER->start;
961 }, 1193 },
962); 1194);
963 1195
964_reload_2; 1196IO::AIO::max_poll_time $TICK * 0.2;
1197
1198Event->io (fd => IO::AIO::poll_fileno,
1199 poll => 'r',
1200 prio => 5,
1201 cb => \&IO::AIO::poll_cb);
965 1202
9661 12031
967 1204

Diff Legend

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