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

Diff Legend

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