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.77 by root, Sun Nov 5 11:13:01 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
… …
679 1 696 1
680 } or warn "$ext not loaded: $@"; 697 } or warn "$ext not loaded: $@";
681 } 698 }
682} 699}
683 700
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
760############################################################################# 701#############################################################################
761# extcmd framework, basically convert ext <msg> 702# extcmd framework, basically convert ext <msg>
762# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 703# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
763 704
764attach_to_players 705attach_to_players
… …
816 } 757 }
817 }, 758 },
818; 759;
819 760
820############################################################################# 761#############################################################################
821# core extensions - in perl 762
763=head2 CORE EXTENSIONS
764
765Functions and methods that extend core crossfire objects.
766
767=over 4
822 768
823=item cf::player::exists $login 769=item cf::player::exists $login
824 770
825Returns true when the given account exists. 771Returns true when the given account exists.
826 772
… …
829sub cf::player::exists($) { 775sub cf::player::exists($) {
830 cf::player::find $_[0] 776 cf::player::find $_[0]
831 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 777 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
832} 778}
833 779
834=item $player->reply ($npc, $msg[, $flags]) 780=item $object->reply ($npc, $msg[, $flags])
835 781
836Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 782Sends 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 783can be C<undef>. Does the right thing when the player is currently in a
838dialogue with the given NPC character. 784dialogue with the given NPC character.
839 785
… …
866 $msg{msgid} = $id; 812 $msg{msgid} = $id;
867 813
868 $self->send ("ext " . to_json \%msg); 814 $self->send ("ext " . to_json \%msg);
869} 815}
870 816
817=back
818
819=cut
820
871############################################################################# 821#############################################################################
872# map scripting support 822
823=head2 SAFE SCRIPTING
824
825Functions that provide a safe environment to compile and execute
826snippets of perl code without them endangering the safety of the server
827itself. Looping constructs, I/O operators and other built-in functionality
828is not available in the safe scripting environment, and the number of
829functions and methods that cna be called is greatly reduced.
830
831=cut
873 832
874our $safe = new Safe "safe"; 833our $safe = new Safe "safe";
875our $safe_hole = new Safe::Hole; 834our $safe_hole = new Safe::Hole;
876 835
877$SIG{FPE} = 'IGNORE'; 836$SIG{FPE} = 'IGNORE';
878 837
879$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 838$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
880 839
881# here we export the classes and methods available to script code 840# here we export the classes and methods available to script code
841
842=pod
843
844The following fucntions and emthods are available within a safe environment:
845
846 cf::object contr pay_amount pay_player
847 cf::object::player player
848 cf::player peaceful
849
850=cut
882 851
883for ( 852for (
884 ["cf::object" => qw(contr pay_amount pay_player)], 853 ["cf::object" => qw(contr pay_amount pay_player)],
885 ["cf::object::player" => qw(player)], 854 ["cf::object::player" => qw(player)],
886 ["cf::player" => qw(peaceful)], 855 ["cf::player" => qw(peaceful)],
… …
889 my ($pkg, @funs) = @$_; 858 my ($pkg, @funs) = @$_;
890 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 859 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
891 for @funs; 860 for @funs;
892} 861}
893 862
863=over 4
864
865=item @retval = safe_eval $code, [var => value, ...]
866
867Compiled and executes the given perl code snippet. additional var/value
868pairs result in temporary local (my) scalar variables of the given name
869that are available in the code snippet. Example:
870
871 my $five = safe_eval '$first + $second', first => 1, second => 4;
872
873=cut
874
894sub safe_eval($;@) { 875sub safe_eval($;@) {
895 my ($code, %vars) = @_; 876 my ($code, %vars) = @_;
896 877
897 my $qcode = $code; 878 my $qcode = $code;
898 $qcode =~ s/"/‟/g; # not allowed in #line filenames 879 $qcode =~ s/"/‟/g; # not allowed in #line filenames
… …
920 } 901 }
921 902
922 wantarray ? @res : $res[0] 903 wantarray ? @res : $res[0]
923} 904}
924 905
906=item cf::register_script_function $function => $cb
907
908Register a function that can be called from within map/npc scripts. The
909function should be reasonably secure and should be put into a package name
910like the extension.
911
912Example: register a function that gets called whenever a map script calls
913C<rent::overview>, as used by the C<rent> extension.
914
915 cf::register_script_function "rent::overview" => sub {
916 ...
917 };
918
919=cut
920
925sub register_script_function { 921sub register_script_function {
926 my ($fun, $cb) = @_; 922 my ($fun, $cb) = @_;
927 923
928 no strict 'refs'; 924 no strict 'refs';
929 *{"safe::$fun"} = $safe_hole->wrap ($cb); 925 *{"safe::$fun"} = $safe_hole->wrap ($cb);
930} 926}
931 927
928=back
929
930=cut
931
932#############################################################################
933
934=head2 EXTENSION DATABASE SUPPORT
935
936Crossfire maintains a very simple database for extension use. It can
937currently store anything that can be serialised using Storable, which
938excludes objects.
939
940The parameter C<$family> should best start with the name of the extension
941using it, it should be unique.
942
943=over 4
944
945=item $hashref = cf::db_get $family
946
947Return a hashref for use by the extension C<$family>, which can be
948modified. After modifications, you have to call C<cf::db_dirty> or
949C<cf::db_sync>.
950
951=item $value = cf::db_get $family => $key
952
953Returns a single value from the database
954
955=item cf::db_put $family => $hashref
956
957Stores the given family hashref into the database. Updates are delayed, if
958you want the data to be synced to disk immediately, use C<cf::db_sync>.
959
960=item cf::db_put $family => $key => $value
961
962Stores the given C<$value> in the family hash. Updates are delayed, if you
963want the data to be synced to disk immediately, use C<cf::db_sync>.
964
965=item cf::db_dirty
966
967Marks the database as dirty, to be updated at a later time.
968
969=item cf::db_sync
970
971Immediately write the database to disk I<if it is dirty>.
972
973=cut
974
975{
976 my $db;
977 my $path = cf::localdir . "/database.pst";
978
979 sub db_load() {
980 warn "loading database $path\n";#d# remove later
981 $db = stat $path ? Storable::retrieve $path : { };
982 }
983
984 my $pid;
985
986 sub db_save() {
987 warn "saving database $path\n";#d# remove later
988 waitpid $pid, 0 if $pid;
989 if (0 == ($pid = fork)) {
990 $db->{_meta}{version} = 1;
991 Storable::nstore $db, "$path~";
992 rename "$path~", $path;
993 cf::_exit 0 if defined $pid;
994 }
995 }
996
997 my $dirty;
998
999 sub db_sync() {
1000 db_save if $dirty;
1001 undef $dirty;
1002 }
1003
1004 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub {
1005 db_sync;
1006 });
1007
1008 sub db_dirty() {
1009 $dirty = 1;
1010 $idle->start;
1011 }
1012
1013 sub db_get($;$) {
1014 @_ >= 2
1015 ? $db->{$_[0]}{$_[1]}
1016 : ($db->{$_[0]} ||= { })
1017 }
1018
1019 sub db_put($$;$) {
1020 if (@_ >= 3) {
1021 $db->{$_[0]}{$_[1]} = $_[2];
1022 } else {
1023 $db->{$_[0]} = $_[1];
1024 }
1025 db_dirty;
1026 }
1027
1028 attach_global
1029 prio => 10000,
1030 on_cleanup => sub {
1031 db_sync;
1032 },
1033 ;
1034}
1035
932############################################################################# 1036#############################################################################
933# the server's main() 1037# the server's main()
934 1038
1039sub cfg_load {
1040 open my $fh, "<:utf8", cf::confdir . "/config"
1041 or return;
1042
1043 local $/;
1044 *CFG = YAML::Syck::Load <$fh>;
1045}
1046
935sub main { 1047sub main {
1048 cfg_load;
1049 db_load;
936 load_extensions; 1050 load_extensions;
937 Event::loop; 1051 Event::loop;
938} 1052}
939 1053
940############################################################################# 1054#############################################################################
941# initialisation 1055# initialisation
942 1056
1057sub _perl_reload(&) {
1058 my ($msg) = @_;
1059
1060 $msg->("reloading...");
1061
1062 eval {
1063 # cancel all watchers
1064 $_->cancel for Event::all_watchers;
1065
1066 # unload all extensions
1067 for (@exts) {
1068 $msg->("unloading <$_>");
1069 unload_extension $_;
1070 }
1071
1072 # unload all modules loaded from $LIBDIR
1073 while (my ($k, $v) = each %INC) {
1074 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1075
1076 $msg->("removing <$k>");
1077 delete $INC{$k};
1078
1079 $k =~ s/\.pm$//;
1080 $k =~ s/\//::/g;
1081
1082 if (my $cb = $k->can ("unload_module")) {
1083 $cb->();
1084 }
1085
1086 Symbol::delete_package $k;
1087 }
1088
1089 # sync database to disk
1090 cf::db_sync;
1091
1092 # get rid of safe::, as good as possible
1093 Symbol::delete_package "safe::$_"
1094 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
1095
1096 # remove register_script_function callbacks
1097 # TODO
1098
1099 # unload cf.pm "a bit"
1100 delete $INC{"cf.pm"};
1101
1102 # don't, removes xs symbols, too,
1103 # and global variables created in xs
1104 #Symbol::delete_package __PACKAGE__;
1105
1106 # reload cf.pm
1107 $msg->("reloading cf.pm");
1108 require cf;
1109
1110 # load config and database again
1111 cf::cfg_load;
1112 cf::db_load;
1113
1114 # load extensions
1115 $msg->("load extensions");
1116 cf::load_extensions;
1117
1118 # reattach attachments to objects
1119 $msg->("reattach");
1120 _global_reattach;
1121 };
1122 $msg->($@) if $@;
1123
1124 $msg->("reloaded");
1125};
1126
1127sub perl_reload() {
1128 _perl_reload {
1129 warn $_[0];
1130 print "$_[0]\n";
1131 };
1132}
1133
1134register_command "perl-reload", 0, sub {
1135 my ($who, $arg) = @_;
1136
1137 if ($who->flag (FLAG_WIZ)) {
1138 _perl_reload {
1139 warn $_[0];
1140 $who->message ($_[0]);
1141 };
1142 }
1143};
1144
943register "<global>", __PACKAGE__; 1145register "<global>", __PACKAGE__;
944 1146
945unshift @INC, $LIBDIR; 1147unshift @INC, $LIBDIR;
946 1148
947$TICK_WATCHER = Event->timer ( 1149$TICK_WATCHER = Event->timer (
948 prio => 1, 1150 prio => 1,
1151 async => 1,
949 at => $NEXT_TICK || 1, 1152 at => $NEXT_TICK || 1,
950 cb => sub { 1153 cb => sub {
951 cf::server_tick; # one server iteration 1154 cf::server_tick; # one server iteration
952 1155
953 my $NOW = Event::time; 1156 my $NOW = Event::time;
954 $NEXT_TICK += $TICK; 1157 $NEXT_TICK += $TICK;
955 1158
… …
959 $TICK_WATCHER->at ($NEXT_TICK); 1162 $TICK_WATCHER->at ($NEXT_TICK);
960 $TICK_WATCHER->start; 1163 $TICK_WATCHER->start;
961 }, 1164 },
962); 1165);
963 1166
964_reload_2; 1167IO::AIO::max_poll_time $TICK * 0.2;
1168
1169Event->io (fd => IO::AIO::poll_fileno,
1170 poll => 'r',
1171 prio => 5,
1172 cb => \&IO::AIO::poll_cb);
965 1173
9661 11741
967 1175

Diff Legend

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