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.60 by root, Thu Aug 31 06:23:19 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
539 local $/;
540
541 my $av;
542
543 #TODO: use sysread etc.
544 if (open my $data, "<:raw:perlio", $filename) {
545 $data = <$data>;
514 open my $fh, "<:raw:perlio", "$filename.pst" 546 if (open my $pst, "<:raw:perlio", "$filename.pst") {
515 or return; 547 $av = eval { (Storable::thaw <$pst>)->{objs} };
548 }
549 return ($data, $av);
550 }
516 551
517 eval { local $/; (Storable::thaw <$fh>)->{objs} } 552 ()
518} 553}
519 554
520attach_to_objects 555attach_to_objects
521 prio => -1000000, 556 prio => -1000000,
522 on_clone => sub { 557 on_clone => sub {
… …
668 load_extension $ext; 703 load_extension $ext;
669 1 704 1
670 } or warn "$ext not loaded: $@"; 705 } or warn "$ext not loaded: $@";
671 } 706 }
672} 707}
673
674sub _perl_reload(&) {
675 my ($msg) = @_;
676
677 $msg->("reloading...");
678
679 eval {
680 # 1. cancel all watchers
681 $_->cancel for Event::all_watchers;
682
683 # 2. unload all extensions
684 for (@exts) {
685 $msg->("unloading <$_>");
686 unload_extension $_;
687 }
688
689 # 3. unload all modules loaded from $LIBDIR
690 while (my ($k, $v) = each %INC) {
691 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
692
693 $msg->("removing <$k>");
694 delete $INC{$k};
695
696 $k =~ s/\.pm$//;
697 $k =~ s/\//::/g;
698
699 if (my $cb = $k->can ("unload_module")) {
700 $cb->();
701 }
702
703 Symbol::delete_package $k;
704 }
705
706 # 4. get rid of safe::, as good as possible
707 Symbol::delete_package "safe::$_"
708 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
709
710 # 5. remove register_script_function callbacks
711 # TODO
712
713 # 6. unload cf.pm "a bit"
714 delete $INC{"cf.pm"};
715
716 # don't, removes xs symbols, too,
717 # and global variables created in xs
718 #Symbol::delete_package __PACKAGE__;
719
720 # 7. reload cf.pm
721 $msg->("reloading cf.pm");
722 require cf;
723 };
724 $msg->($@) if $@;
725
726 $msg->("reloaded");
727};
728
729sub perl_reload() {
730 _perl_reload {
731 warn $_[0];
732 print "$_[0]\n";
733 };
734}
735
736register_command "perl-reload", 0, sub {
737 my ($who, $arg) = @_;
738
739 if ($who->flag (FLAG_WIZ)) {
740 _perl_reload {
741 warn $_[0];
742 $who->message ($_[0]);
743 };
744 }
745};
746 708
747############################################################################# 709#############################################################################
748# extcmd framework, basically convert ext <msg> 710# extcmd framework, basically convert ext <msg>
749# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 711# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
750 712
… …
803 } 765 }
804 }, 766 },
805; 767;
806 768
807############################################################################# 769#############################################################################
808# core extensions - in perl 770
771=head2 CORE EXTENSIONS
772
773Functions and methods that extend core crossfire objects.
774
775=over 4
809 776
810=item cf::player::exists $login 777=item cf::player::exists $login
811 778
812Returns true when the given account exists. 779Returns true when the given account exists.
813 780
… …
816sub cf::player::exists($) { 783sub cf::player::exists($) {
817 cf::player::find $_[0] 784 cf::player::find $_[0]
818 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;
819} 786}
820 787
821=item $player->reply ($npc, $msg[, $flags]) 788=item $player_object->reply ($npc, $msg[, $flags])
822 789
823Sends 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>
824can 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
825dialogue with the given NPC character. 792dialogue with the given NPC character.
826 793
… …
853 $msg{msgid} = $id; 820 $msg{msgid} = $id;
854 821
855 $self->send ("ext " . to_json \%msg); 822 $self->send ("ext " . to_json \%msg);
856} 823}
857 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
858############################################################################# 843#############################################################################
859# 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
860 854
861our $safe = new Safe "safe"; 855our $safe = new Safe "safe";
862our $safe_hole = new Safe::Hole; 856our $safe_hole = new Safe::Hole;
863 857
864$SIG{FPE} = 'IGNORE'; 858$SIG{FPE} = 'IGNORE';
865 859
866$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));
867 861
868# 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
869 873
870for ( 874for (
871 ["cf::object" => qw(contr pay_amount pay_player)], 875 ["cf::object" => qw(contr pay_amount pay_player)],
872 ["cf::object::player" => qw(player)], 876 ["cf::object::player" => qw(player)],
873 ["cf::player" => qw(peaceful)], 877 ["cf::player" => qw(peaceful)],
… …
876 my ($pkg, @funs) = @$_; 880 my ($pkg, @funs) = @$_;
877 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 881 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
878 for @funs; 882 for @funs;
879} 883}
880 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
881sub safe_eval($;@) { 897sub safe_eval($;@) {
882 my ($code, %vars) = @_; 898 my ($code, %vars) = @_;
883 899
884 my $qcode = $code; 900 my $qcode = $code;
885 $qcode =~ s/"/‟/g; # not allowed in #line filenames 901 $qcode =~ s/"/‟/g; # not allowed in #line filenames
… …
907 } 923 }
908 924
909 wantarray ? @res : $res[0] 925 wantarray ? @res : $res[0]
910} 926}
911 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
912sub register_script_function { 943sub register_script_function {
913 my ($fun, $cb) = @_; 944 my ($fun, $cb) = @_;
914 945
915 no strict 'refs'; 946 no strict 'refs';
916 *{"safe::$fun"} = $safe_hole->wrap ($cb); 947 *{"safe::$fun"} = $safe_hole->wrap ($cb);
917} 948}
918 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
919############################################################################# 1059#############################################################################
920# the server's main() 1060# the server's main()
921 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
922sub main { 1070sub main {
1071 cfg_load;
1072 db_load;
1073 load_extensions;
923 Event::loop; 1074 Event::loop;
924} 1075}
925 1076
926############################################################################# 1077#############################################################################
927# initialisation 1078# initialisation
928 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
929register "<global>", __PACKAGE__; 1168register "<global>", __PACKAGE__;
930 1169
931unshift @INC, $LIBDIR; 1170unshift @INC, $LIBDIR;
932 1171
933load_extensions;
934
935$TICK_WATCHER = Event->timer ( 1172$TICK_WATCHER = Event->timer (
936 prio => 1, 1173 prio => 1,
1174 async => 1,
937 at => $NEXT_TICK || 1, 1175 at => $NEXT_TICK || 1,
938 cb => sub { 1176 cb => sub {
939 cf::server_tick; # one server iteration 1177 cf::server_tick; # one server iteration
940 1178
941 my $NOW = Event::time; 1179 my $NOW = Event::time;
942 $NEXT_TICK += $TICK; 1180 $NEXT_TICK += $TICK;
943 1181
944 # if we are delayed by four ticks, skip them all 1182 # if we are delayed by four ticks or more, skip them all
945 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1183 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
946 1184
947 $TICK_WATCHER->at ($NEXT_TICK); 1185 $TICK_WATCHER->at ($NEXT_TICK);
948 $TICK_WATCHER->start; 1186 $TICK_WATCHER->start;
949 }, 1187 },
950); 1188);
951 1189
952_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);
953 1196
9541 11971
955 1198

Diff Legend

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